Code

lib-git-svn.sh: Move web-server handling code into separate function
[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@laptop.org>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use 5.008;
19 use strict;
20 use warnings;
21 use bytes;
23 use Fcntl;
24 use File::Temp qw/tempdir tempfile/;
25 use File::Path qw/rmtree/;
26 use File::Basename;
27 use Getopt::Long qw(:config require_order no_ignore_case);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS::log->new();
32 my $cfg;
34 my $DATE_LIST = {
35     Jan => "01",
36     Feb => "02",
37     Mar => "03",
38     Apr => "04",
39     May => "05",
40     Jun => "06",
41     Jul => "07",
42     Aug => "08",
43     Sep => "09",
44     Oct => "10",
45     Nov => "11",
46     Dec => "12",
47 };
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50 $| = 1;
52 #### Definition and mappings of functions ####
54 my $methods = {
55     'Root'            => \&req_Root,
56     'Valid-responses' => \&req_Validresponses,
57     'valid-requests'  => \&req_validrequests,
58     'Directory'       => \&req_Directory,
59     'Entry'           => \&req_Entry,
60     'Modified'        => \&req_Modified,
61     'Unchanged'       => \&req_Unchanged,
62     'Questionable'    => \&req_Questionable,
63     'Argument'        => \&req_Argument,
64     'Argumentx'       => \&req_Argument,
65     'expand-modules'  => \&req_expandmodules,
66     'add'             => \&req_add,
67     'remove'          => \&req_remove,
68     'co'              => \&req_co,
69     'update'          => \&req_update,
70     'ci'              => \&req_ci,
71     'diff'            => \&req_diff,
72     'log'             => \&req_log,
73     'rlog'            => \&req_log,
74     'tag'             => \&req_CATCHALL,
75     'status'          => \&req_status,
76     'admin'           => \&req_CATCHALL,
77     'history'         => \&req_CATCHALL,
78     'watchers'        => \&req_EMPTY,
79     'editors'         => \&req_EMPTY,
80     'noop'            => \&req_EMPTY,
81     'annotate'        => \&req_annotate,
82     'Global_option'   => \&req_Globaloption,
83     #'annotate'        => \&req_CATCHALL,
84 };
86 ##############################################
89 # $state holds all the bits of information the clients sends us that could
90 # potentially be useful when it comes to actually _doing_ something.
91 my $state = { prependdir => '' };
93 # Work is for managing temporary working directory
94 my $work =
95     {
96         state => undef,  # undef, 1 (empty), 2 (with stuff)
97         workDir => undef,
98         index => undef,
99         emptyDir => undef,
100         tmpDir => undef
101     };
103 $log->info("--------------- STARTING -----------------");
105 my $usage =
106     "Usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
107     "    --base-path <path>  : Prepend to requested CVSROOT\n".
108     "                          Can be read from GIT_CVSSERVER_BASE_PATH\n".
109     "    --strict-paths      : Don't allow recursing into subdirectories\n".
110     "    --export-all        : Don't check for gitcvs.enabled in config\n".
111     "    --version, -V       : Print version information and exit\n".
112     "    --help, -h, -H      : Print usage information and exit\n".
113     "\n".
114     "<directory> ... is a list of allowed directories. If no directories\n".
115     "are given, all are allowed. This is an additional restriction, gitcvs\n".
116     "access still needs to be enabled by the gitcvs.enabled config option.\n".
117     "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
119 my @opts = ( 'help|h|H', 'version|V',
120              'base-path=s', 'strict-paths', 'export-all' );
121 GetOptions( $state, @opts )
122     or die $usage;
124 if ($state->{version}) {
125     print "git-cvsserver version $VERSION\n";
126     exit;
128 if ($state->{help}) {
129     print $usage;
130     exit;
133 my $TEMP_DIR = tempdir( CLEANUP => 1 );
134 $log->debug("Temporary directory is '$TEMP_DIR'");
136 $state->{method} = 'ext';
137 if (@ARGV) {
138     if ($ARGV[0] eq 'pserver') {
139         $state->{method} = 'pserver';
140         shift @ARGV;
141     } elsif ($ARGV[0] eq 'server') {
142         shift @ARGV;
143     }
146 # everything else is a directory
147 $state->{allowed_roots} = [ @ARGV ];
149 # don't export the whole system unless the users requests it
150 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
151     die "--export-all can only be used together with an explicit whitelist\n";
154 # Environment handling for running under git-shell
155 if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
156     if ($state->{'base-path'}) {
157         die "Cannot specify base path both ways.\n";
158     }
159     my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH};
160     $state->{'base-path'} = $base_path;
161     $log->debug("Picked up base path '$base_path' from environment.\n");
163 if (exists $ENV{GIT_CVSSERVER_ROOT}) {
164     if (@{$state->{allowed_roots}}) {
165         die "Cannot specify roots both ways: @ARGV\n";
166     }
167     my $allowed_root = $ENV{GIT_CVSSERVER_ROOT};
168     $state->{allowed_roots} = [ $allowed_root ];
169     $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
172 # if we are called with a pserver argument,
173 # deal with the authentication cat before entering the
174 # main loop
175 if ($state->{method} eq 'pserver') {
176     my $line = <STDIN>; chomp $line;
177     unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
178        die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
179     }
180     my $request = $1;
181     $line = <STDIN>; chomp $line;
182     unless (req_Root('root', $line)) { # reuse Root
183        print "E Invalid root $line \n";
184        exit 1;
185     }
186     $line = <STDIN>; chomp $line;
187     my $user = $line;
188     $line = <STDIN>; chomp $line;
189     my $password = $line;
191     if ($user eq 'anonymous') {
192         # "A" will be 1 byte, use length instead in case the
193         # encryption method ever changes (yeah, right!)
194         if (length($password) > 1 ) {
195             print "E Don't supply a password for the `anonymous' user\n";
196             print "I HATE YOU\n";
197             exit 1;
198         }
200         # Fall through to LOVE
201     } else {
202         # Trying to authenticate a user
203         if (not exists $cfg->{gitcvs}->{authdb}) {
204             print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
205             print "I HATE YOU\n";
206             exit 1;
207         }
209         my $authdb = $cfg->{gitcvs}->{authdb};
211         unless (-e $authdb) {
212             print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
213             print "I HATE YOU\n";
214             exit 1;
215         }
217         my $auth_ok;
218         open my $passwd, "<", $authdb or die $!;
219         while (<$passwd>) {
220             if (m{^\Q$user\E:(.*)}) {
221                 if (crypt($user, descramble($password)) eq $1) {
222                     $auth_ok = 1;
223                 }
224             };
225         }
226         close $passwd;
228         unless ($auth_ok) {
229             print "I HATE YOU\n";
230             exit 1;
231         }
233         # Fall through to LOVE
234     }
236     # For checking whether the user is anonymous on commit
237     $state->{user} = $user;
239     $line = <STDIN>; chomp $line;
240     unless ($line eq "END $request REQUEST") {
241        die "E Do not understand $line -- expecting END $request REQUEST\n";
242     }
243     print "I LOVE YOU\n";
244     exit if $request eq 'VERIFICATION'; # cvs login
245     # and now back to our regular programme...
248 # Keep going until the client closes the connection
249 while (<STDIN>)
251     chomp;
253     # Check to see if we've seen this method, and call appropriate function.
254     if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
255     {
256         # use the $methods hash to call the appropriate sub for this command
257         #$log->info("Method : $1");
258         &{$methods->{$1}}($1,$2);
259     } else {
260         # log fatal because we don't understand this function. If this happens
261         # we're fairly screwed because we don't know if the client is expecting
262         # a response. If it is, the client will hang, we'll hang, and the whole
263         # thing will be custard.
264         $log->fatal("Don't understand command $_\n");
265         die("Unknown command $_");
266     }
269 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
270 $log->info("--------------- FINISH -----------------");
272 chdir '/';
273 exit 0;
275 # Magic catchall method.
276 #    This is the method that will handle all commands we haven't yet
277 #    implemented. It simply sends a warning to the log file indicating a
278 #    command that hasn't been implemented has been invoked.
279 sub req_CATCHALL
281     my ( $cmd, $data ) = @_;
282     $log->warn("Unhandled command : req_$cmd : $data");
285 # This method invariably succeeds with an empty response.
286 sub req_EMPTY
288     print "ok\n";
291 # Root pathname \n
292 #     Response expected: no. Tell the server which CVSROOT to use. Note that
293 #     pathname is a local directory and not a fully qualified CVSROOT variable.
294 #     pathname must already exist; if creating a new root, use the init
295 #     request, not Root. pathname does not include the hostname of the server,
296 #     how to access the server, etc.; by the time the CVS protocol is in use,
297 #     connection, authentication, etc., are already taken care of. The Root
298 #     request must be sent only once, and it must be sent before any requests
299 #     other than Valid-responses, valid-requests, UseUnchanged, Set or init.
300 sub req_Root
302     my ( $cmd, $data ) = @_;
303     $log->debug("req_Root : $data");
305     unless ($data =~ m#^/#) {
306         print "error 1 Root must be an absolute pathname\n";
307         return 0;
308     }
310     my $cvsroot = $state->{'base-path'} || '';
311     $cvsroot =~ s#/+$##;
312     $cvsroot .= $data;
314     if ($state->{CVSROOT}
315         && ($state->{CVSROOT} ne $cvsroot)) {
316         print "error 1 Conflicting roots specified\n";
317         return 0;
318     }
320     $state->{CVSROOT} = $cvsroot;
322     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
324     if (@{$state->{allowed_roots}}) {
325         my $allowed = 0;
326         foreach my $dir (@{$state->{allowed_roots}}) {
327             next unless $dir =~ m#^/#;
328             $dir =~ s#/+$##;
329             if ($state->{'strict-paths'}) {
330                 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
331                     $allowed = 1;
332                     last;
333                 }
334             } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
335                 $allowed = 1;
336                 last;
337             }
338         }
340         unless ($allowed) {
341             print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
342             print "E \n";
343             print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
344             return 0;
345         }
346     }
348     unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
349        print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
350        print "E \n";
351        print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
352        return 0;
353     }
355     my @gitvars = `git config -l`;
356     if ($?) {
357        print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
358         print "E \n";
359         print "error 1 - problem executing git-config\n";
360        return 0;
361     }
362     foreach my $line ( @gitvars )
363     {
364         next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
365         unless ($2) {
366             $cfg->{$1}{$3} = $4;
367         } else {
368             $cfg->{$1}{$2}{$3} = $4;
369         }
370     }
372     my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
373                    || $cfg->{gitcvs}{enabled});
374     unless ($state->{'export-all'} ||
375             ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
376         print "E GITCVS emulation needs to be enabled on this repo\n";
377         print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
378         print "E \n";
379         print "error 1 GITCVS emulation disabled\n";
380         return 0;
381     }
383     my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
384     if ( $logfile )
385     {
386         $log->setfile($logfile);
387     } else {
388         $log->nofile();
389     }
391     return 1;
394 # Global_option option \n
395 #     Response expected: no. Transmit one of the global options `-q', `-Q',
396 #     `-l', `-t', `-r', or `-n'. option must be one of those strings, no
397 #     variations (such as combining of options) are allowed. For graceful
398 #     handling of valid-requests, it is probably better to make new global
399 #     options separate requests, rather than trying to add them to this
400 #     request.
401 sub req_Globaloption
403     my ( $cmd, $data ) = @_;
404     $log->debug("req_Globaloption : $data");
405     $state->{globaloptions}{$data} = 1;
408 # Valid-responses request-list \n
409 #     Response expected: no. Tell the server what responses the client will
410 #     accept. request-list is a space separated list of tokens.
411 sub req_Validresponses
413     my ( $cmd, $data ) = @_;
414     $log->debug("req_Validresponses : $data");
416     # TODO : re-enable this, currently it's not particularly useful
417     #$state->{validresponses} = [ split /\s+/, $data ];
420 # valid-requests \n
421 #     Response expected: yes. Ask the server to send back a Valid-requests
422 #     response.
423 sub req_validrequests
425     my ( $cmd, $data ) = @_;
427     $log->debug("req_validrequests");
429     $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
430     $log->debug("SEND : ok");
432     print "Valid-requests " . join(" ",keys %$methods) . "\n";
433     print "ok\n";
436 # Directory local-directory \n
437 #     Additional data: repository \n. Response expected: no. Tell the server
438 #     what directory to use. The repository should be a directory name from a
439 #     previous server response. Note that this both gives a default for Entry
440 #     and Modified and also for ci and the other commands; normal usage is to
441 #     send Directory for each directory in which there will be an Entry or
442 #     Modified, and then a final Directory for the original directory, then the
443 #     command. The local-directory is relative to the top level at which the
444 #     command is occurring (i.e. the last Directory which is sent before the
445 #     command); to indicate that top level, `.' should be sent for
446 #     local-directory.
447 sub req_Directory
449     my ( $cmd, $data ) = @_;
451     my $repository = <STDIN>;
452     chomp $repository;
455     $state->{localdir} = $data;
456     $state->{repository} = $repository;
457     $state->{path} = $repository;
458     $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
459     $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
460     $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
462     $state->{directory} = $state->{localdir};
463     $state->{directory} = "" if ( $state->{directory} eq "." );
464     $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
466     if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
467     {
468         $log->info("Setting prepend to '$state->{path}'");
469         $state->{prependdir} = $state->{path};
470         foreach my $entry ( keys %{$state->{entries}} )
471         {
472             $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
473             delete $state->{entries}{$entry};
474         }
475     }
477     if ( defined ( $state->{prependdir} ) )
478     {
479         $log->debug("Prepending '$state->{prependdir}' to state|directory");
480         $state->{directory} = $state->{prependdir} . $state->{directory}
481     }
482     $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
485 # Entry entry-line \n
486 #     Response expected: no. Tell the server what version of a file is on the
487 #     local machine. The name in entry-line is a name relative to the directory
488 #     most recently specified with Directory. If the user is operating on only
489 #     some files in a directory, Entry requests for only those files need be
490 #     included. If an Entry request is sent without Modified, Is-modified, or
491 #     Unchanged, it means the file is lost (does not exist in the working
492 #     directory). If both Entry and one of Modified, Is-modified, or Unchanged
493 #     are sent for the same file, Entry must be sent first. For a given file,
494 #     one can send Modified, Is-modified, or Unchanged, but not more than one
495 #     of these three.
496 sub req_Entry
498     my ( $cmd, $data ) = @_;
500     #$log->debug("req_Entry : $data");
502     my @data = split(/\//, $data);
504     $state->{entries}{$state->{directory}.$data[1]} = {
505         revision    => $data[2],
506         conflict    => $data[3],
507         options     => $data[4],
508         tag_or_date => $data[5],
509     };
511     $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
514 # Questionable filename \n
515 #     Response expected: no. Additional data: no. Tell the server to check
516 #     whether filename should be ignored, and if not, next time the server
517 #     sends responses, send (in a M response) `?' followed by the directory and
518 #     filename. filename must not contain `/'; it needs to be a file in the
519 #     directory named by the most recent Directory request.
520 sub req_Questionable
522     my ( $cmd, $data ) = @_;
524     $log->debug("req_Questionable : $data");
525     $state->{entries}{$state->{directory}.$data}{questionable} = 1;
528 # add \n
529 #     Response expected: yes. Add a file or directory. This uses any previous
530 #     Argument, Directory, Entry, or Modified requests, if they have been sent.
531 #     The last Directory sent specifies the working directory at the time of
532 #     the operation. To add a directory, send the directory to be added using
533 #     Directory and Argument requests.
534 sub req_add
536     my ( $cmd, $data ) = @_;
538     argsplit("add");
540     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
541     $updater->update();
543     argsfromdir($updater);
545     my $addcount = 0;
547     foreach my $filename ( @{$state->{args}} )
548     {
549         $filename = filecleanup($filename);
551         my $meta = $updater->getmeta($filename);
552         my $wrev = revparse($filename);
554         if ($wrev && $meta && ($wrev < 0))
555         {
556             # previously removed file, add back
557             $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
559             print "MT +updated\n";
560             print "MT text U \n";
561             print "MT fname $filename\n";
562             print "MT newline\n";
563             print "MT -updated\n";
565             unless ( $state->{globaloptions}{-n} )
566             {
567                 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
569                 print "Created $dirpart\n";
570                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
572                 # this is an "entries" line
573                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
574                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
575                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
576                 # permissions
577                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
578                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
579                 # transmit file
580                 transmitfile($meta->{filehash});
581             }
583             next;
584         }
586         unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
587         {
588             print "E cvs add: nothing known about `$filename'\n";
589             next;
590         }
591         # TODO : check we're not squashing an already existing file
592         if ( defined ( $state->{entries}{$filename}{revision} ) )
593         {
594             print "E cvs add: `$filename' has already been entered\n";
595             next;
596         }
598         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
600         print "E cvs add: scheduling file `$filename' for addition\n";
602         print "Checked-in $dirpart\n";
603         print "$filename\n";
604         my $kopts = kopts_from_path($filename,"file",
605                         $state->{entries}{$filename}{modified_filename});
606         print "/$filepart/0//$kopts/\n";
608         my $requestedKopts = $state->{opt}{k};
609         if(defined($requestedKopts))
610         {
611             $requestedKopts = "-k$requestedKopts";
612         }
613         else
614         {
615             $requestedKopts = "";
616         }
617         if( $kopts ne $requestedKopts )
618         {
619             $log->warn("Ignoring requested -k='$requestedKopts'"
620                         . " for '$filename'; detected -k='$kopts' instead");
621             #TODO: Also have option to send warning to user?
622         }
624         $addcount++;
625     }
627     if ( $addcount == 1 )
628     {
629         print "E cvs add: use `cvs commit' to add this file permanently\n";
630     }
631     elsif ( $addcount > 1 )
632     {
633         print "E cvs add: use `cvs commit' to add these files permanently\n";
634     }
636     print "ok\n";
639 # remove \n
640 #     Response expected: yes. Remove a file. This uses any previous Argument,
641 #     Directory, Entry, or Modified requests, if they have been sent. The last
642 #     Directory sent specifies the working directory at the time of the
643 #     operation. Note that this request does not actually do anything to the
644 #     repository; the only effect of a successful remove request is to supply
645 #     the client with a new entries line containing `-' to indicate a removed
646 #     file. In fact, the client probably could perform this operation without
647 #     contacting the server, although using remove may cause the server to
648 #     perform a few more checks. The client sends a subsequent ci request to
649 #     actually record the removal in the repository.
650 sub req_remove
652     my ( $cmd, $data ) = @_;
654     argsplit("remove");
656     # Grab a handle to the SQLite db and do any necessary updates
657     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
658     $updater->update();
660     #$log->debug("add state : " . Dumper($state));
662     my $rmcount = 0;
664     foreach my $filename ( @{$state->{args}} )
665     {
666         $filename = filecleanup($filename);
668         if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
669         {
670             print "E cvs remove: file `$filename' still in working directory\n";
671             next;
672         }
674         my $meta = $updater->getmeta($filename);
675         my $wrev = revparse($filename);
677         unless ( defined ( $wrev ) )
678         {
679             print "E cvs remove: nothing known about `$filename'\n";
680             next;
681         }
683         if ( defined($wrev) and $wrev < 0 )
684         {
685             print "E cvs remove: file `$filename' already scheduled for removal\n";
686             next;
687         }
689         unless ( $wrev == $meta->{revision} )
690         {
691             # TODO : not sure if the format of this message is quite correct.
692             print "E cvs remove: Up to date check failed for `$filename'\n";
693             next;
694         }
697         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
699         print "E cvs remove: scheduling `$filename' for removal\n";
701         print "Checked-in $dirpart\n";
702         print "$filename\n";
703         my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
704         print "/$filepart/-1.$wrev//$kopts/\n";
706         $rmcount++;
707     }
709     if ( $rmcount == 1 )
710     {
711         print "E cvs remove: use `cvs commit' to remove this file permanently\n";
712     }
713     elsif ( $rmcount > 1 )
714     {
715         print "E cvs remove: use `cvs commit' to remove these files permanently\n";
716     }
718     print "ok\n";
721 # Modified filename \n
722 #     Response expected: no. Additional data: mode, \n, file transmission. Send
723 #     the server a copy of one locally modified file. filename is a file within
724 #     the most recent directory sent with Directory; it must not contain `/'.
725 #     If the user is operating on only some files in a directory, only those
726 #     files need to be included. This can also be sent without Entry, if there
727 #     is no entry for the file.
728 sub req_Modified
730     my ( $cmd, $data ) = @_;
732     my $mode = <STDIN>;
733     defined $mode
734         or (print "E end of file reading mode for $data\n"), return;
735     chomp $mode;
736     my $size = <STDIN>;
737     defined $size
738         or (print "E end of file reading size of $data\n"), return;
739     chomp $size;
741     # Grab config information
742     my $blocksize = 8192;
743     my $bytesleft = $size;
744     my $tmp;
746     # Get a filehandle/name to write it to
747     my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
749     # Loop over file data writing out to temporary file.
750     while ( $bytesleft )
751     {
752         $blocksize = $bytesleft if ( $bytesleft < $blocksize );
753         read STDIN, $tmp, $blocksize;
754         print $fh $tmp;
755         $bytesleft -= $blocksize;
756     }
758     close $fh
759         or (print "E failed to write temporary, $filename: $!\n"), return;
761     # Ensure we have something sensible for the file mode
762     if ( $mode =~ /u=(\w+)/ )
763     {
764         $mode = $1;
765     } else {
766         $mode = "rw";
767     }
769     # Save the file data in $state
770     $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
771     $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
772     $state->{entries}{$state->{directory}.$data}{modified_hash} = `git hash-object $filename`;
773     $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
775     #$log->debug("req_Modified : file=$data mode=$mode size=$size");
778 # Unchanged filename \n
779 #     Response expected: no. Tell the server that filename has not been
780 #     modified in the checked out directory. The filename is a file within the
781 #     most recent directory sent with Directory; it must not contain `/'.
782 sub req_Unchanged
784     my ( $cmd, $data ) = @_;
786     $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
788     #$log->debug("req_Unchanged : $data");
791 # Argument text \n
792 #     Response expected: no. Save argument for use in a subsequent command.
793 #     Arguments accumulate until an argument-using command is given, at which
794 #     point they are forgotten.
795 # Argumentx text \n
796 #     Response expected: no. Append \n followed by text to the current argument
797 #     being saved.
798 sub req_Argument
800     my ( $cmd, $data ) = @_;
802     # Argumentx means: append to last Argument (with a newline in front)
804     $log->debug("$cmd : $data");
806     if ( $cmd eq 'Argumentx') {
807         ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
808     } else {
809         push @{$state->{arguments}}, $data;
810     }
813 # expand-modules \n
814 #     Response expected: yes. Expand the modules which are specified in the
815 #     arguments. Returns the data in Module-expansion responses. Note that the
816 #     server can assume that this is checkout or export, not rtag or rdiff; the
817 #     latter do not access the working directory and thus have no need to
818 #     expand modules on the client side. Expand may not be the best word for
819 #     what this request does. It does not necessarily tell you all the files
820 #     contained in a module, for example. Basically it is a way of telling you
821 #     which working directories the server needs to know about in order to
822 #     handle a checkout of the specified modules. For example, suppose that the
823 #     server has a module defined by
824 #   aliasmodule -a 1dir
825 #     That is, one can check out aliasmodule and it will take 1dir in the
826 #     repository and check it out to 1dir in the working directory. Now suppose
827 #     the client already has this module checked out and is planning on using
828 #     the co request to update it. Without using expand-modules, the client
829 #     would have two bad choices: it could either send information about all
830 #     working directories under the current directory, which could be
831 #     unnecessarily slow, or it could be ignorant of the fact that aliasmodule
832 #     stands for 1dir, and neglect to send information for 1dir, which would
833 #     lead to incorrect operation. With expand-modules, the client would first
834 #     ask for the module to be expanded:
835 sub req_expandmodules
837     my ( $cmd, $data ) = @_;
839     argsplit();
841     $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
843     unless ( ref $state->{arguments} eq "ARRAY" )
844     {
845         print "ok\n";
846         return;
847     }
849     foreach my $module ( @{$state->{arguments}} )
850     {
851         $log->debug("SEND : Module-expansion $module");
852         print "Module-expansion $module\n";
853     }
855     print "ok\n";
856     statecleanup();
859 # co \n
860 #     Response expected: yes. Get files from the repository. This uses any
861 #     previous Argument, Directory, Entry, or Modified requests, if they have
862 #     been sent. Arguments to this command are module names; the client cannot
863 #     know what directories they correspond to except by (1) just sending the
864 #     co request, and then seeing what directory names the server sends back in
865 #     its responses, and (2) the expand-modules request.
866 sub req_co
868     my ( $cmd, $data ) = @_;
870     argsplit("co");
872     # Provide list of modules, if -c was used.
873     if (exists $state->{opt}{c}) {
874         my $showref = `git show-ref --heads`;
875         for my $line (split '\n', $showref) {
876             if ( $line =~ m% refs/heads/(.*)$% ) {
877                 print "M $1\t$1\n";
878             }
879         }
880         print "ok\n";
881         return 1;
882     }
884     my $module = $state->{args}[0];
885     $state->{module} = $module;
886     my $checkout_path = $module;
888     # use the user specified directory if we're given it
889     $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
891     $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
893     $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
895     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
897     # Grab a handle to the SQLite db and do any necessary updates
898     my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
899     $updater->update();
901     $checkout_path =~ s|/$||; # get rid of trailing slashes
903     # Eclipse seems to need the Clear-sticky command
904     # to prepare the 'Entries' file for the new directory.
905     print "Clear-sticky $checkout_path/\n";
906     print $state->{CVSROOT} . "/$module/\n";
907     print "Clear-static-directory $checkout_path/\n";
908     print $state->{CVSROOT} . "/$module/\n";
909     print "Clear-sticky $checkout_path/\n"; # yes, twice
910     print $state->{CVSROOT} . "/$module/\n";
911     print "Template $checkout_path/\n";
912     print $state->{CVSROOT} . "/$module/\n";
913     print "0\n";
915     # instruct the client that we're checking out to $checkout_path
916     print "E cvs checkout: Updating $checkout_path\n";
918     my %seendirs = ();
919     my $lastdir ='';
921     # recursive
922     sub prepdir {
923        my ($dir, $repodir, $remotedir, $seendirs) = @_;
924        my $parent = dirname($dir);
925        $dir       =~ s|/+$||;
926        $repodir   =~ s|/+$||;
927        $remotedir =~ s|/+$||;
928        $parent    =~ s|/+$||;
929        $log->debug("announcedir $dir, $repodir, $remotedir" );
931        if ($parent eq '.' || $parent eq './') {
932            $parent = '';
933        }
934        # recurse to announce unseen parents first
935        if (length($parent) && !exists($seendirs->{$parent})) {
936            prepdir($parent, $repodir, $remotedir, $seendirs);
937        }
938        # Announce that we are going to modify at the parent level
939        if ($parent) {
940            print "E cvs checkout: Updating $remotedir/$parent\n";
941        } else {
942            print "E cvs checkout: Updating $remotedir\n";
943        }
944        print "Clear-sticky $remotedir/$parent/\n";
945        print "$repodir/$parent/\n";
947        print "Clear-static-directory $remotedir/$dir/\n";
948        print "$repodir/$dir/\n";
949        print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
950        print "$repodir/$parent/\n";
951        print "Template $remotedir/$dir/\n";
952        print "$repodir/$dir/\n";
953        print "0\n";
955        $seendirs->{$dir} = 1;
956     }
958     foreach my $git ( @{$updater->gethead} )
959     {
960         # Don't want to check out deleted files
961         next if ( $git->{filehash} eq "deleted" );
963         my $fullName = $git->{name};
964         ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
966        if (length($git->{dir}) && $git->{dir} ne './'
967            && $git->{dir} ne $lastdir ) {
968            unless (exists($seendirs{$git->{dir}})) {
969                prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
970                        $checkout_path, \%seendirs);
971                $lastdir = $git->{dir};
972                $seendirs{$git->{dir}} = 1;
973            }
974            print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
975        }
977         # modification time of this file
978         print "Mod-time $git->{modified}\n";
980         # print some information to the client
981         if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
982         {
983             print "M U $checkout_path/$git->{dir}$git->{name}\n";
984         } else {
985             print "M U $checkout_path/$git->{name}\n";
986         }
988        # instruct client we're sending a file to put in this path
989        print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
991        print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
993         # this is an "entries" line
994         my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
995         print "/$git->{name}/1.$git->{revision}//$kopts/\n";
996         # permissions
997         print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
999         # transmit file
1000         transmitfile($git->{filehash});
1001     }
1003     print "ok\n";
1005     statecleanup();
1008 # update \n
1009 #     Response expected: yes. Actually do a cvs update command. This uses any
1010 #     previous Argument, Directory, Entry, or Modified requests, if they have
1011 #     been sent. The last Directory sent specifies the working directory at the
1012 #     time of the operation. The -I option is not used--files which the client
1013 #     can decide whether to ignore are not mentioned and the client sends the
1014 #     Questionable request for others.
1015 sub req_update
1017     my ( $cmd, $data ) = @_;
1019     $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1021     argsplit("update");
1023     #
1024     # It may just be a client exploring the available heads/modules
1025     # in that case, list them as top level directories and leave it
1026     # at that. Eclipse uses this technique to offer you a list of
1027     # projects (heads in this case) to checkout.
1028     #
1029     if ($state->{module} eq '') {
1030         my $showref = `git show-ref --heads`;
1031         print "E cvs update: Updating .\n";
1032         for my $line (split '\n', $showref) {
1033             if ( $line =~ m% refs/heads/(.*)$% ) {
1034                 print "E cvs update: New directory `$1'\n";
1035             }
1036         }
1037         print "ok\n";
1038         return 1;
1039     }
1042     # Grab a handle to the SQLite db and do any necessary updates
1043     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1045     $updater->update();
1047     argsfromdir($updater);
1049     #$log->debug("update state : " . Dumper($state));
1051     my $last_dirname = "///";
1053     # foreach file specified on the command line ...
1054     foreach my $filename ( @{$state->{args}} )
1055     {
1056         $filename = filecleanup($filename);
1058         $log->debug("Processing file $filename");
1060         unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1061         {
1062             my $cur_dirname = dirname($filename);
1063             if ( $cur_dirname ne $last_dirname )
1064             {
1065                 $last_dirname = $cur_dirname;
1066                 if ( $cur_dirname eq "" )
1067                 {
1068                     $cur_dirname = ".";
1069                 }
1070                 print "E cvs update: Updating $cur_dirname\n";
1071             }
1072         }
1074         # if we have a -C we should pretend we never saw modified stuff
1075         if ( exists ( $state->{opt}{C} ) )
1076         {
1077             delete $state->{entries}{$filename}{modified_hash};
1078             delete $state->{entries}{$filename}{modified_filename};
1079             $state->{entries}{$filename}{unchanged} = 1;
1080         }
1082         my $meta;
1083         if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
1084         {
1085             $meta = $updater->getmeta($filename, $1);
1086         } else {
1087             $meta = $updater->getmeta($filename);
1088         }
1090         # If -p was given, "print" the contents of the requested revision.
1091         if ( exists ( $state->{opt}{p} ) ) {
1092             if ( defined ( $meta->{revision} ) ) {
1093                 $log->info("Printing '$filename' revision " . $meta->{revision});
1095                 transmitfile($meta->{filehash}, { print => 1 });
1096             }
1098             next;
1099         }
1101         if ( ! defined $meta )
1102         {
1103             $meta = {
1104                 name => $filename,
1105                 revision => 0,
1106                 filehash => 'added'
1107             };
1108         }
1110         my $oldmeta = $meta;
1112         my $wrev = revparse($filename);
1114         # If the working copy is an old revision, lets get that version too for comparison.
1115         if ( defined($wrev) and $wrev != $meta->{revision} )
1116         {
1117             $oldmeta = $updater->getmeta($filename, $wrev);
1118         }
1120         #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1122         # Files are up to date if the working copy and repo copy have the same revision,
1123         # and the working copy is unmodified _and_ the user hasn't specified -C
1124         next if ( defined ( $wrev )
1125                   and defined($meta->{revision})
1126                   and $wrev == $meta->{revision}
1127                   and $state->{entries}{$filename}{unchanged}
1128                   and not exists ( $state->{opt}{C} ) );
1130         # If the working copy and repo copy have the same revision,
1131         # but the working copy is modified, tell the client it's modified
1132         if ( defined ( $wrev )
1133              and defined($meta->{revision})
1134              and $wrev == $meta->{revision}
1135              and defined($state->{entries}{$filename}{modified_hash})
1136              and not exists ( $state->{opt}{C} ) )
1137         {
1138             $log->info("Tell the client the file is modified");
1139             print "MT text M \n";
1140             print "MT fname $filename\n";
1141             print "MT newline\n";
1142             next;
1143         }
1145         if ( $meta->{filehash} eq "deleted" )
1146         {
1147             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1149             $log->info("Removing '$filename' from working copy (no longer in the repo)");
1151             print "E cvs update: `$filename' is no longer in the repository\n";
1152             # Don't want to actually _DO_ the update if -n specified
1153             unless ( $state->{globaloptions}{-n} ) {
1154                 print "Removed $dirpart\n";
1155                 print "$filepart\n";
1156             }
1157         }
1158         elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1159                 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1160                 or $meta->{filehash} eq 'added' )
1161         {
1162             # normal update, just send the new revision (either U=Update,
1163             # or A=Add, or R=Remove)
1164             if ( defined($wrev) && $wrev < 0 )
1165             {
1166                 $log->info("Tell the client the file is scheduled for removal");
1167                 print "MT text R \n";
1168                 print "MT fname $filename\n";
1169                 print "MT newline\n";
1170                 next;
1171             }
1172             elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1173             {
1174                 $log->info("Tell the client the file is scheduled for addition");
1175                 print "MT text A \n";
1176                 print "MT fname $filename\n";
1177                 print "MT newline\n";
1178                 next;
1180             }
1181             else {
1182                 $log->info("Updating '$filename' to ".$meta->{revision});
1183                 print "MT +updated\n";
1184                 print "MT text U \n";
1185                 print "MT fname $filename\n";
1186                 print "MT newline\n";
1187                 print "MT -updated\n";
1188             }
1190             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1192             # Don't want to actually _DO_ the update if -n specified
1193             unless ( $state->{globaloptions}{-n} )
1194             {
1195                 if ( defined ( $wrev ) )
1196                 {
1197                     # instruct client we're sending a file to put in this path as a replacement
1198                     print "Update-existing $dirpart\n";
1199                     $log->debug("Updating existing file 'Update-existing $dirpart'");
1200                 } else {
1201                     # instruct client we're sending a file to put in this path as a new file
1202                     print "Clear-static-directory $dirpart\n";
1203                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1204                     print "Clear-sticky $dirpart\n";
1205                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1207                     $log->debug("Creating new file 'Created $dirpart'");
1208                     print "Created $dirpart\n";
1209                 }
1210                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1212                 # this is an "entries" line
1213                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1214                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1215                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1217                 # permissions
1218                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1219                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1221                 # transmit file
1222                 transmitfile($meta->{filehash});
1223             }
1224         } else {
1225             $log->info("Updating '$filename'");
1226             my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1228             my $mergeDir = setupTmpDir();
1230             my $file_local = $filepart . ".mine";
1231             my $mergedFile = "$mergeDir/$file_local";
1232             system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1233             my $file_old = $filepart . "." . $oldmeta->{revision};
1234             transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1235             my $file_new = $filepart . "." . $meta->{revision};
1236             transmitfile($meta->{filehash}, { targetfile => $file_new });
1238             # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1239             $log->info("Merging $file_local, $file_old, $file_new");
1240             print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1242             $log->debug("Temporary directory for merge is $mergeDir");
1244             my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1245             $return >>= 8;
1247             cleanupTmpDir();
1249             if ( $return == 0 )
1250             {
1251                 $log->info("Merged successfully");
1252                 print "M M $filename\n";
1253                 $log->debug("Merged $dirpart");
1255                 # Don't want to actually _DO_ the update if -n specified
1256                 unless ( $state->{globaloptions}{-n} )
1257                 {
1258                     print "Merged $dirpart\n";
1259                     $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1260                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1261                     my $kopts = kopts_from_path("$dirpart/$filepart",
1262                                                 "file",$mergedFile);
1263                     $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1264                     print "/$filepart/1.$meta->{revision}//$kopts/\n";
1265                 }
1266             }
1267             elsif ( $return == 1 )
1268             {
1269                 $log->info("Merged with conflicts");
1270                 print "E cvs update: conflicts found in $filename\n";
1271                 print "M C $filename\n";
1273                 # Don't want to actually _DO_ the update if -n specified
1274                 unless ( $state->{globaloptions}{-n} )
1275                 {
1276                     print "Merged $dirpart\n";
1277                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1278                     my $kopts = kopts_from_path("$dirpart/$filepart",
1279                                                 "file",$mergedFile);
1280                     print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1281                 }
1282             }
1283             else
1284             {
1285                 $log->warn("Merge failed");
1286                 next;
1287             }
1289             # Don't want to actually _DO_ the update if -n specified
1290             unless ( $state->{globaloptions}{-n} )
1291             {
1292                 # permissions
1293                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1294                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1296                 # transmit file, format is single integer on a line by itself (file
1297                 # size) followed by the file contents
1298                 # TODO : we should copy files in blocks
1299                 my $data = `cat $mergedFile`;
1300                 $log->debug("File size : " . length($data));
1301                 print length($data) . "\n";
1302                 print $data;
1303             }
1304         }
1306     }
1308     print "ok\n";
1311 sub req_ci
1313     my ( $cmd, $data ) = @_;
1315     argsplit("ci");
1317     #$log->debug("State : " . Dumper($state));
1319     $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1321     if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
1322     {
1323         print "error 1 anonymous user cannot commit via pserver\n";
1324         cleanupWorkTree();
1325         exit;
1326     }
1328     if ( -e $state->{CVSROOT} . "/index" )
1329     {
1330         $log->warn("file 'index' already exists in the git repository");
1331         print "error 1 Index already exists in git repo\n";
1332         cleanupWorkTree();
1333         exit;
1334     }
1336     # Grab a handle to the SQLite db and do any necessary updates
1337     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1338     $updater->update();
1340     # Remember where the head was at the beginning.
1341     my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1342     chomp $parenthash;
1343     if ($parenthash !~ /^[0-9a-f]{40}$/) {
1344             print "error 1 pserver cannot find the current HEAD of module";
1345             cleanupWorkTree();
1346             exit;
1347     }
1349     setupWorkTree($parenthash);
1351     $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1353     $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1355     my @committedfiles = ();
1356     my %oldmeta;
1358     # foreach file specified on the command line ...
1359     foreach my $filename ( @{$state->{args}} )
1360     {
1361         my $committedfile = $filename;
1362         $filename = filecleanup($filename);
1364         next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1366         my $meta = $updater->getmeta($filename);
1367         $oldmeta{$filename} = $meta;
1369         my $wrev = revparse($filename);
1371         my ( $filepart, $dirpart ) = filenamesplit($filename);
1373         # do a checkout of the file if it is part of this tree
1374         if ($wrev) {
1375             system('git', 'checkout-index', '-f', '-u', $filename);
1376             unless ($? == 0) {
1377                 die "Error running git-checkout-index -f -u $filename : $!";
1378             }
1379         }
1381         my $addflag = 0;
1382         my $rmflag = 0;
1383         $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1384         $addflag = 1 unless ( -e $filename );
1386         # Do up to date checking
1387         unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1388         {
1389             # fail everything if an up to date check fails
1390             print "error 1 Up to date check failed for $filename\n";
1391             cleanupWorkTree();
1392             exit;
1393         }
1395         push @committedfiles, $committedfile;
1396         $log->info("Committing $filename");
1398         system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1400         unless ( $rmflag )
1401         {
1402             $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1403             rename $state->{entries}{$filename}{modified_filename},$filename;
1405             # Calculate modes to remove
1406             my $invmode = "";
1407             foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1409             $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1410             system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1411         }
1413         if ( $rmflag )
1414         {
1415             $log->info("Removing file '$filename'");
1416             unlink($filename);
1417             system("git", "update-index", "--remove", $filename);
1418         }
1419         elsif ( $addflag )
1420         {
1421             $log->info("Adding file '$filename'");
1422             system("git", "update-index", "--add", $filename);
1423         } else {
1424             $log->info("Updating file '$filename'");
1425             system("git", "update-index", $filename);
1426         }
1427     }
1429     unless ( scalar(@committedfiles) > 0 )
1430     {
1431         print "E No files to commit\n";
1432         print "ok\n";
1433         cleanupWorkTree();
1434         return;
1435     }
1437     my $treehash = `git write-tree`;
1438     chomp $treehash;
1440     $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1442     # write our commit message out if we have one ...
1443     my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1444     print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1445     if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1446         if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1447             print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1448         }
1449     } else {
1450         print $msg_fh "\n\nvia git-CVS emulator\n";
1451     }
1452     close $msg_fh;
1454     my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename`;
1455     chomp($commithash);
1456     $log->info("Commit hash : $commithash");
1458     unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1459     {
1460         $log->warn("Commit failed (Invalid commit hash)");
1461         print "error 1 Commit failed (unknown reason)\n";
1462         cleanupWorkTree();
1463         exit;
1464     }
1466         ### Emulate git-receive-pack by running hooks/update
1467         my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1468                         $parenthash, $commithash );
1469         if( -x $hook[0] ) {
1470                 unless( system( @hook ) == 0 )
1471                 {
1472                         $log->warn("Commit failed (update hook declined to update ref)");
1473                         print "error 1 Commit failed (update hook declined)\n";
1474                         cleanupWorkTree();
1475                         exit;
1476                 }
1477         }
1479         ### Update the ref
1480         if (system(qw(git update-ref -m), "cvsserver ci",
1481                         "refs/heads/$state->{module}", $commithash, $parenthash)) {
1482                 $log->warn("update-ref for $state->{module} failed.");
1483                 print "error 1 Cannot commit -- update first\n";
1484                 cleanupWorkTree();
1485                 exit;
1486         }
1488         ### Emulate git-receive-pack by running hooks/post-receive
1489         my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1490         if( -x $hook ) {
1491                 open(my $pipe, "| $hook") || die "can't fork $!";
1493                 local $SIG{PIPE} = sub { die 'pipe broke' };
1495                 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1497                 close $pipe || die "bad pipe: $! $?";
1498         }
1500     $updater->update();
1502         ### Then hooks/post-update
1503         $hook = $ENV{GIT_DIR}.'hooks/post-update';
1504         if (-x $hook) {
1505                 system($hook, "refs/heads/$state->{module}");
1506         }
1508     # foreach file specified on the command line ...
1509     foreach my $filename ( @committedfiles )
1510     {
1511         $filename = filecleanup($filename);
1513         my $meta = $updater->getmeta($filename);
1514         unless (defined $meta->{revision}) {
1515           $meta->{revision} = 1;
1516         }
1518         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1520         $log->debug("Checked-in $dirpart : $filename");
1522         print "M $state->{CVSROOT}/$state->{module}/$filename,v  <--  $dirpart$filepart\n";
1523         if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1524         {
1525             print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1526             print "Remove-entry $dirpart\n";
1527             print "$filename\n";
1528         } else {
1529             if ($meta->{revision} == 1) {
1530                 print "M initial revision: 1.1\n";
1531             } else {
1532                 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1533             }
1534             print "Checked-in $dirpart\n";
1535             print "$filename\n";
1536             my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1537             print "/$filepart/1.$meta->{revision}//$kopts/\n";
1538         }
1539     }
1541     cleanupWorkTree();
1542     print "ok\n";
1545 sub req_status
1547     my ( $cmd, $data ) = @_;
1549     argsplit("status");
1551     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1552     #$log->debug("status state : " . Dumper($state));
1554     # Grab a handle to the SQLite db and do any necessary updates
1555     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1556     $updater->update();
1558     # if no files were specified, we need to work out what files we should be providing status on ...
1559     argsfromdir($updater);
1561     # foreach file specified on the command line ...
1562     foreach my $filename ( @{$state->{args}} )
1563     {
1564         $filename = filecleanup($filename);
1566         next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1568         my $meta = $updater->getmeta($filename);
1569         my $oldmeta = $meta;
1571         my $wrev = revparse($filename);
1573         # If the working copy is an old revision, lets get that version too for comparison.
1574         if ( defined($wrev) and $wrev != $meta->{revision} )
1575         {
1576             $oldmeta = $updater->getmeta($filename, $wrev);
1577         }
1579         # TODO : All possible statuses aren't yet implemented
1580         my $status;
1581         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1582         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1583                                     and
1584                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1585                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1586                                    );
1588         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1589         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1590                                           and
1591                                           ( $state->{entries}{$filename}{unchanged}
1592                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1593                                         );
1595         # Need checkout if it exists in the repo but doesn't have a working copy
1596         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1598         # Locally modified if working copy and repo copy have the same revision but there are local changes
1599         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1601         # Needs Merge if working copy revision is less than repo copy and there are local changes
1602         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1604         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1605         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1606         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1607         $status ||= "File had conflicts on merge" if ( 0 );
1609         $status ||= "Unknown";
1611         my ($filepart) = filenamesplit($filename);
1613         print "M ===================================================================\n";
1614         print "M File: $filepart\tStatus: $status\n";
1615         if ( defined($state->{entries}{$filename}{revision}) )
1616         {
1617             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1618         } else {
1619             print "M Working revision:\tNo entry for $filename\n";
1620         }
1621         if ( defined($meta->{revision}) )
1622         {
1623             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1624             print "M Sticky Tag:\t\t(none)\n";
1625             print "M Sticky Date:\t\t(none)\n";
1626             print "M Sticky Options:\t\t(none)\n";
1627         } else {
1628             print "M Repository revision:\tNo revision control file\n";
1629         }
1630         print "M\n";
1631     }
1633     print "ok\n";
1636 sub req_diff
1638     my ( $cmd, $data ) = @_;
1640     argsplit("diff");
1642     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1643     #$log->debug("status state : " . Dumper($state));
1645     my ($revision1, $revision2);
1646     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1647     {
1648         $revision1 = $state->{opt}{r}[0];
1649         $revision2 = $state->{opt}{r}[1];
1650     } else {
1651         $revision1 = $state->{opt}{r};
1652     }
1654     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1655     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1657     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1659     # Grab a handle to the SQLite db and do any necessary updates
1660     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1661     $updater->update();
1663     # if no files were specified, we need to work out what files we should be providing status on ...
1664     argsfromdir($updater);
1666     # foreach file specified on the command line ...
1667     foreach my $filename ( @{$state->{args}} )
1668     {
1669         $filename = filecleanup($filename);
1671         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1673         my $wrev = revparse($filename);
1675         # We need _something_ to diff against
1676         next unless ( defined ( $wrev ) );
1678         # if we have a -r switch, use it
1679         if ( defined ( $revision1 ) )
1680         {
1681             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1682             $meta1 = $updater->getmeta($filename, $revision1);
1683             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1684             {
1685                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1686                 next;
1687             }
1688             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1689         }
1690         # otherwise we just use the working copy revision
1691         else
1692         {
1693             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1694             $meta1 = $updater->getmeta($filename, $wrev);
1695             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1696         }
1698         # if we have a second -r switch, use it too
1699         if ( defined ( $revision2 ) )
1700         {
1701             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1702             $meta2 = $updater->getmeta($filename, $revision2);
1704             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1705             {
1706                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1707                 next;
1708             }
1710             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1711         }
1712         # otherwise we just use the working copy
1713         else
1714         {
1715             $file2 = $state->{entries}{$filename}{modified_filename};
1716         }
1718         # if we have been given -r, and we don't have a $file2 yet, lets get one
1719         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1720         {
1721             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1722             $meta2 = $updater->getmeta($filename, $wrev);
1723             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1724         }
1726         # We need to have retrieved something useful
1727         next unless ( defined ( $meta1 ) );
1729         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1730         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1731                   and
1732                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1733                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1734                   );
1736         # Apparently we only show diffs for locally modified files
1737         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1739         print "M Index: $filename\n";
1740         print "M ===================================================================\n";
1741         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1742         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1743         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1744         print "M diff ";
1745         foreach my $opt ( keys %{$state->{opt}} )
1746         {
1747             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1748             {
1749                 foreach my $value ( @{$state->{opt}{$opt}} )
1750                 {
1751                     print "-$opt $value ";
1752                 }
1753             } else {
1754                 print "-$opt ";
1755                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1756             }
1757         }
1758         print "$filename\n";
1760         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1762         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1764         if ( exists $state->{opt}{u} )
1765         {
1766             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1767         } else {
1768             system("diff $file1 $file2 > $filediff");
1769         }
1771         while ( <$fh> )
1772         {
1773             print "M $_";
1774         }
1775         close $fh;
1776     }
1778     print "ok\n";
1781 sub req_log
1783     my ( $cmd, $data ) = @_;
1785     argsplit("log");
1787     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1788     #$log->debug("log state : " . Dumper($state));
1790     my ( $minrev, $maxrev );
1791     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1792     {
1793         my $control = $2;
1794         $minrev = $1;
1795         $maxrev = $3;
1796         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1797         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1798         $minrev++ if ( defined($minrev) and $control eq "::" );
1799     }
1801     # Grab a handle to the SQLite db and do any necessary updates
1802     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1803     $updater->update();
1805     # if no files were specified, we need to work out what files we should be providing status on ...
1806     argsfromdir($updater);
1808     # foreach file specified on the command line ...
1809     foreach my $filename ( @{$state->{args}} )
1810     {
1811         $filename = filecleanup($filename);
1813         my $headmeta = $updater->getmeta($filename);
1815         my $revisions = $updater->getlog($filename);
1816         my $totalrevisions = scalar(@$revisions);
1818         if ( defined ( $minrev ) )
1819         {
1820             $log->debug("Removing revisions less than $minrev");
1821             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1822             {
1823                 pop @$revisions;
1824             }
1825         }
1826         if ( defined ( $maxrev ) )
1827         {
1828             $log->debug("Removing revisions greater than $maxrev");
1829             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1830             {
1831                 shift @$revisions;
1832             }
1833         }
1835         next unless ( scalar(@$revisions) );
1837         print "M \n";
1838         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1839         print "M Working file: $filename\n";
1840         print "M head: 1.$headmeta->{revision}\n";
1841         print "M branch:\n";
1842         print "M locks: strict\n";
1843         print "M access list:\n";
1844         print "M symbolic names:\n";
1845         print "M keyword substitution: kv\n";
1846         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1847         print "M description:\n";
1849         foreach my $revision ( @$revisions )
1850         {
1851             print "M ----------------------------\n";
1852             print "M revision 1.$revision->{revision}\n";
1853             # reformat the date for log output
1854             $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}) );
1855             $revision->{author} = cvs_author($revision->{author});
1856             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1857             my $commitmessage = $updater->commitmessage($revision->{commithash});
1858             $commitmessage =~ s/^/M /mg;
1859             print $commitmessage . "\n";
1860         }
1861         print "M =============================================================================\n";
1862     }
1864     print "ok\n";
1867 sub req_annotate
1869     my ( $cmd, $data ) = @_;
1871     argsplit("annotate");
1873     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1874     #$log->debug("status state : " . Dumper($state));
1876     # Grab a handle to the SQLite db and do any necessary updates
1877     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1878     $updater->update();
1880     # if no files were specified, we need to work out what files we should be providing annotate on ...
1881     argsfromdir($updater);
1883     # we'll need a temporary checkout dir
1884     setupWorkTree();
1886     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1888     # foreach file specified on the command line ...
1889     foreach my $filename ( @{$state->{args}} )
1890     {
1891         $filename = filecleanup($filename);
1893         my $meta = $updater->getmeta($filename);
1895         next unless ( $meta->{revision} );
1897         # get all the commits that this file was in
1898         # in dense format -- aka skip dead revisions
1899         my $revisions   = $updater->gethistorydense($filename);
1900         my $lastseenin  = $revisions->[0][2];
1902         # populate the temporary index based on the latest commit were we saw
1903         # the file -- but do it cheaply without checking out any files
1904         # TODO: if we got a revision from the client, use that instead
1905         # to look up the commithash in sqlite (still good to default to
1906         # the current head as we do now)
1907         system("git", "read-tree", $lastseenin);
1908         unless ($? == 0)
1909         {
1910             print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1911             return;
1912         }
1913         $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1915         # do a checkout of the file
1916         system('git', 'checkout-index', '-f', '-u', $filename);
1917         unless ($? == 0) {
1918             print "E error running git-checkout-index -f -u $filename : $!\n";
1919             return;
1920         }
1922         $log->info("Annotate $filename");
1924         # Prepare a file with the commits from the linearized
1925         # history that annotate should know about. This prevents
1926         # git-jsannotate telling us about commits we are hiding
1927         # from the client.
1929         my $a_hints = "$work->{workDir}/.annotate_hints";
1930         if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1931             print "E failed to open '$a_hints' for writing: $!\n";
1932             return;
1933         }
1934         for (my $i=0; $i < @$revisions; $i++)
1935         {
1936             print ANNOTATEHINTS $revisions->[$i][2];
1937             if ($i+1 < @$revisions) { # have we got a parent?
1938                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1939             }
1940             print ANNOTATEHINTS "\n";
1941         }
1943         print ANNOTATEHINTS "\n";
1944         close ANNOTATEHINTS
1945             or (print "E failed to write $a_hints: $!\n"), return;
1947         my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
1948         if (!open(ANNOTATE, "-|", @cmd)) {
1949             print "E error invoking ". join(' ',@cmd) .": $!\n";
1950             return;
1951         }
1952         my $metadata = {};
1953         print "E Annotations for $filename\n";
1954         print "E ***************\n";
1955         while ( <ANNOTATE> )
1956         {
1957             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1958             {
1959                 my $commithash = $1;
1960                 my $data = $2;
1961                 unless ( defined ( $metadata->{$commithash} ) )
1962                 {
1963                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1964                     $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1965                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1966                 }
1967                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1968                     $metadata->{$commithash}{revision},
1969                     $metadata->{$commithash}{author},
1970                     $metadata->{$commithash}{modified},
1971                     $data
1972                 );
1973             } else {
1974                 $log->warn("Error in annotate output! LINE: $_");
1975                 print "E Annotate error \n";
1976                 next;
1977             }
1978         }
1979         close ANNOTATE;
1980     }
1982     # done; get out of the tempdir
1983     cleanupWorkTree();
1985     print "ok\n";
1989 # This method takes the state->{arguments} array and produces two new arrays.
1990 # The first is $state->{args} which is everything before the '--' argument, and
1991 # the second is $state->{files} which is everything after it.
1992 sub argsplit
1994     $state->{args} = [];
1995     $state->{files} = [];
1996     $state->{opt} = {};
1998     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2000     my $type = shift;
2002     if ( defined($type) )
2003     {
2004         my $opt = {};
2005         $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" );
2006         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
2007         $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" );
2008         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
2009         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
2010         $opt = { k => 1, m => 1 } if ( $type eq "add" );
2011         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
2012         $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" );
2015         while ( scalar ( @{$state->{arguments}} ) > 0 )
2016         {
2017             my $arg = shift @{$state->{arguments}};
2019             next if ( $arg eq "--" );
2020             next unless ( $arg =~ /\S/ );
2022             # if the argument looks like a switch
2023             if ( $arg =~ /^-(\w)(.*)/ )
2024             {
2025                 # if it's a switch that takes an argument
2026                 if ( $opt->{$1} )
2027                 {
2028                     # If this switch has already been provided
2029                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2030                     {
2031                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
2032                         if ( length($2) > 0 )
2033                         {
2034                             push @{$state->{opt}{$1}},$2;
2035                         } else {
2036                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2037                         }
2038                     } else {
2039                         # if there's extra data in the arg, use that as the argument for the switch
2040                         if ( length($2) > 0 )
2041                         {
2042                             $state->{opt}{$1} = $2;
2043                         } else {
2044                             $state->{opt}{$1} = shift @{$state->{arguments}};
2045                         }
2046                     }
2047                 } else {
2048                     $state->{opt}{$1} = undef;
2049                 }
2050             }
2051             else
2052             {
2053                 push @{$state->{args}}, $arg;
2054             }
2055         }
2056     }
2057     else
2058     {
2059         my $mode = 0;
2061         foreach my $value ( @{$state->{arguments}} )
2062         {
2063             if ( $value eq "--" )
2064             {
2065                 $mode++;
2066                 next;
2067             }
2068             push @{$state->{args}}, $value if ( $mode == 0 );
2069             push @{$state->{files}}, $value if ( $mode == 1 );
2070         }
2071     }
2074 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2075 sub argsfromdir
2077     my $updater = shift;
2079     $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
2081     return if ( scalar ( @{$state->{args}} ) > 1 );
2083     my @gethead = @{$updater->gethead};
2085     # push added files
2086     foreach my $file (keys %{$state->{entries}}) {
2087         if ( exists $state->{entries}{$file}{revision} &&
2088                 $state->{entries}{$file}{revision} == 0 )
2089         {
2090             push @gethead, { name => $file, filehash => 'added' };
2091         }
2092     }
2094     if ( scalar(@{$state->{args}}) == 1 )
2095     {
2096         my $arg = $state->{args}[0];
2097         $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2099         $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2101         foreach my $file ( @gethead )
2102         {
2103             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2104             next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg  );
2105             push @{$state->{args}}, $file->{name};
2106         }
2108         shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2109     } else {
2110         $log->info("Only one arg specified, populating file list automatically");
2112         $state->{args} = [];
2114         foreach my $file ( @gethead )
2115         {
2116             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2117             next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2118             push @{$state->{args}}, $file->{name};
2119         }
2120     }
2123 # This method cleans up the $state variable after a command that uses arguments has run
2124 sub statecleanup
2126     $state->{files} = [];
2127     $state->{args} = [];
2128     $state->{arguments} = [];
2129     $state->{entries} = {};
2132 sub revparse
2134     my $filename = shift;
2136     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2138     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2139     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2141     return undef;
2144 # This method takes a file hash and does a CVS "file transfer".  Its
2145 # exact behaviour depends on a second, optional hash table argument:
2146 # - If $options->{targetfile}, dump the contents to that file;
2147 # - If $options->{print}, use M/MT to transmit the contents one line
2148 #   at a time;
2149 # - Otherwise, transmit the size of the file, followed by the file
2150 #   contents.
2151 sub transmitfile
2153     my $filehash = shift;
2154     my $options = shift;
2156     if ( defined ( $filehash ) and $filehash eq "deleted" )
2157     {
2158         $log->warn("filehash is 'deleted'");
2159         return;
2160     }
2162     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2164     my $type = `git cat-file -t $filehash`;
2165     chomp $type;
2167     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2169     my $size = `git cat-file -s $filehash`;
2170     chomp $size;
2172     $log->debug("transmitfile($filehash) size=$size, type=$type");
2174     if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2175     {
2176         if ( defined ( $options->{targetfile} ) )
2177         {
2178             my $targetfile = $options->{targetfile};
2179             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2180             print NEWFILE $_ while ( <$fh> );
2181             close NEWFILE or die("Failed to write '$targetfile': $!");
2182         } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2183             while ( <$fh> ) {
2184                 if( /\n\z/ ) {
2185                     print 'M ', $_;
2186                 } else {
2187                     print 'MT text ', $_, "\n";
2188                 }
2189             }
2190         } else {
2191             print "$size\n";
2192             print while ( <$fh> );
2193         }
2194         close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2195     } else {
2196         die("Couldn't execute git-cat-file");
2197     }
2200 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2201 # refers to the directory portion and the file portion of the filename
2202 # respectively
2203 sub filenamesplit
2205     my $filename = shift;
2206     my $fixforlocaldir = shift;
2208     my ( $filepart, $dirpart ) = ( $filename, "." );
2209     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2210     $dirpart .= "/";
2212     if ( $fixforlocaldir )
2213     {
2214         $dirpart =~ s/^$state->{prependdir}//;
2215     }
2217     return ( $filepart, $dirpart );
2220 sub filecleanup
2222     my $filename = shift;
2224     return undef unless(defined($filename));
2225     if ( $filename =~ /^\// )
2226     {
2227         print "E absolute filenames '$filename' not supported by server\n";
2228         return undef;
2229     }
2231     $filename =~ s/^\.\///g;
2232     $filename = $state->{prependdir} . $filename;
2233     return $filename;
2236 sub validateGitDir
2238     if( !defined($state->{CVSROOT}) )
2239     {
2240         print "error 1 CVSROOT not specified\n";
2241         cleanupWorkTree();
2242         exit;
2243     }
2244     if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2245     {
2246         print "error 1 Internally inconsistent CVSROOT\n";
2247         cleanupWorkTree();
2248         exit;
2249     }
2252 # Setup working directory in a work tree with the requested version
2253 # loaded in the index.
2254 sub setupWorkTree
2256     my ($ver) = @_;
2258     validateGitDir();
2260     if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2261         defined($work->{tmpDir}) )
2262     {
2263         $log->warn("Bad work tree state management");
2264         print "error 1 Internal setup multiple work trees without cleanup\n";
2265         cleanupWorkTree();
2266         exit;
2267     }
2269     $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2271     if( !defined($work->{index}) )
2272     {
2273         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2274     }
2276     chdir $work->{workDir} or
2277         die "Unable to chdir to $work->{workDir}\n";
2279     $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2281     $ENV{GIT_WORK_TREE} = ".";
2282     $ENV{GIT_INDEX_FILE} = $work->{index};
2283     $work->{state} = 2;
2285     if($ver)
2286     {
2287         system("git","read-tree",$ver);
2288         unless ($? == 0)
2289         {
2290             $log->warn("Error running git-read-tree");
2291             die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2292         }
2293     }
2294     # else # req_annotate reads tree for each file
2297 # Ensure current directory is in some kind of working directory,
2298 # with a recent version loaded in the index.
2299 sub ensureWorkTree
2301     if( defined($work->{tmpDir}) )
2302     {
2303         $log->warn("Bad work tree state management [ensureWorkTree()]");
2304         print "error 1 Internal setup multiple dirs without cleanup\n";
2305         cleanupWorkTree();
2306         exit;
2307     }
2308     if( $work->{state} )
2309     {
2310         return;
2311     }
2313     validateGitDir();
2315     if( !defined($work->{emptyDir}) )
2316     {
2317         $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2318     }
2319     chdir $work->{emptyDir} or
2320         die "Unable to chdir to $work->{emptyDir}\n";
2322     my $ver = `git show-ref -s refs/heads/$state->{module}`;
2323     chomp $ver;
2324     if ($ver !~ /^[0-9a-f]{40}$/)
2325     {
2326         $log->warn("Error from git show-ref -s refs/head$state->{module}");
2327         print "error 1 cannot find the current HEAD of module";
2328         cleanupWorkTree();
2329         exit;
2330     }
2332     if( !defined($work->{index}) )
2333     {
2334         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2335     }
2337     $ENV{GIT_WORK_TREE} = ".";
2338     $ENV{GIT_INDEX_FILE} = $work->{index};
2339     $work->{state} = 1;
2341     system("git","read-tree",$ver);
2342     unless ($? == 0)
2343     {
2344         die "Error running git-read-tree $ver $!\n";
2345     }
2348 # Cleanup working directory that is not needed any longer.
2349 sub cleanupWorkTree
2351     if( ! $work->{state} )
2352     {
2353         return;
2354     }
2356     chdir "/" or die "Unable to chdir '/'\n";
2358     if( defined($work->{workDir}) )
2359     {
2360         rmtree( $work->{workDir} );
2361         undef $work->{workDir};
2362     }
2363     undef $work->{state};
2366 # Setup a temporary directory (not a working tree), typically for
2367 # merging dirty state as in req_update.
2368 sub setupTmpDir
2370     $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2371     chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2373     return $work->{tmpDir};
2376 # Clean up a previously setupTmpDir.  Restore previous work tree if
2377 # appropriate.
2378 sub cleanupTmpDir
2380     if ( !defined($work->{tmpDir}) )
2381     {
2382         $log->warn("cleanup tmpdir that has not been setup");
2383         die "Cleanup tmpDir that has not been setup\n";
2384     }
2385     if( defined($work->{state}) )
2386     {
2387         if( $work->{state} == 1 )
2388         {
2389             chdir $work->{emptyDir} or
2390                 die "Unable to chdir to $work->{emptyDir}\n";
2391         }
2392         elsif( $work->{state} == 2 )
2393         {
2394             chdir $work->{workDir} or
2395                 die "Unable to chdir to $work->{emptyDir}\n";
2396         }
2397         else
2398         {
2399             $log->warn("Inconsistent work dir state");
2400             die "Inconsistent work dir state\n";
2401         }
2402     }
2403     else
2404     {
2405         chdir "/" or die "Unable to chdir '/'\n";
2406     }
2409 # Given a path, this function returns a string containing the kopts
2410 # that should go into that path's Entries line.  For example, a binary
2411 # file should get -kb.
2412 sub kopts_from_path
2414     my ($path, $srcType, $name) = @_;
2416     if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2417          $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2418     {
2419         my ($val) = check_attr( "text", $path );
2420         if ( $val eq "unspecified" )
2421         {
2422             $val = check_attr( "crlf", $path );
2423         }
2424         if ( $val eq "unset" )
2425         {
2426             return "-kb"
2427         }
2428         elsif ( check_attr( "eol", $path ) ne "unspecified" ||
2429                 $val eq "set" || $val eq "input" )
2430         {
2431             return "";
2432         }
2433         else
2434         {
2435             $log->info("Unrecognized check_attr crlf $path : $val");
2436         }
2437     }
2439     if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2440     {
2441         if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2442         {
2443             return "-kb";
2444         }
2445         elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2446         {
2447             if( $srcType eq "sha1Or-k" &&
2448                 !defined($name) )
2449             {
2450                 my ($ret)=$state->{entries}{$path}{options};
2451                 if( !defined($ret) )
2452                 {
2453                     $ret=$state->{opt}{k};
2454                     if(defined($ret))
2455                     {
2456                         $ret="-k$ret";
2457                     }
2458                     else
2459                     {
2460                         $ret="";
2461                     }
2462                 }
2463                 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2464                 {
2465                     print "E Bad -k option\n";
2466                     $log->warn("Bad -k option: $ret");
2467                     die "Error: Bad -k option: $ret\n";
2468                 }
2470                 return $ret;
2471             }
2472             else
2473             {
2474                 if( is_binary($srcType,$name) )
2475                 {
2476                     $log->debug("... as binary");
2477                     return "-kb";
2478                 }
2479                 else
2480                 {
2481                     $log->debug("... as text");
2482                 }
2483             }
2484         }
2485     }
2486     # Return "" to give no special treatment to any path
2487     return "";
2490 sub check_attr
2492     my ($attr,$path) = @_;
2493     ensureWorkTree();
2494     if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2495     {
2496         my $val = <$fh>;
2497         close $fh;
2498         $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2499         return $val;
2500     }
2501     else
2502     {
2503         return undef;
2504     }
2507 # This should have the same heuristics as convert.c:is_binary() and related.
2508 # Note that the bare CR test is done by callers in convert.c.
2509 sub is_binary
2511     my ($srcType,$name) = @_;
2512     $log->debug("is_binary($srcType,$name)");
2514     # Minimize amount of interpreted code run in the inner per-character
2515     # loop for large files, by totalling each character value and
2516     # then analyzing the totals.
2517     my @counts;
2518     my $i;
2519     for($i=0;$i<256;$i++)
2520     {
2521         $counts[$i]=0;
2522     }
2524     my $fh = open_blob_or_die($srcType,$name);
2525     my $line;
2526     while( defined($line=<$fh>) )
2527     {
2528         # Any '\0' and bare CR are considered binary.
2529         if( $line =~ /\0|(\r[^\n])/ )
2530         {
2531             close($fh);
2532             return 1;
2533         }
2535         # Count up each character in the line:
2536         my $len=length($line);
2537         for($i=0;$i<$len;$i++)
2538         {
2539             $counts[ord(substr($line,$i,1))]++;
2540         }
2541     }
2542     close $fh;
2544     # Don't count CR and LF as either printable/nonprintable
2545     $counts[ord("\n")]=0;
2546     $counts[ord("\r")]=0;
2548     # Categorize individual character count into printable and nonprintable:
2549     my $printable=0;
2550     my $nonprintable=0;
2551     for($i=0;$i<256;$i++)
2552     {
2553         if( $i < 32 &&
2554             $i != ord("\b") &&
2555             $i != ord("\t") &&
2556             $i != 033 &&       # ESC
2557             $i != 014 )        # FF
2558         {
2559             $nonprintable+=$counts[$i];
2560         }
2561         elsif( $i==127 )  # DEL
2562         {
2563             $nonprintable+=$counts[$i];
2564         }
2565         else
2566         {
2567             $printable+=$counts[$i];
2568         }
2569     }
2571     return ($printable >> 7) < $nonprintable;
2574 # Returns open file handle.  Possible invocations:
2575 #  - open_blob_or_die("file",$filename);
2576 #  - open_blob_or_die("sha1",$filehash);
2577 sub open_blob_or_die
2579     my ($srcType,$name) = @_;
2580     my ($fh);
2581     if( $srcType eq "file" )
2582     {
2583         if( !open $fh,"<",$name )
2584         {
2585             $log->warn("Unable to open file $name: $!");
2586             die "Unable to open file $name: $!\n";
2587         }
2588     }
2589     elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2590     {
2591         unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2592         {
2593             $log->warn("Need filehash");
2594             die "Need filehash\n";
2595         }
2597         my $type = `git cat-file -t $name`;
2598         chomp $type;
2600         unless ( defined ( $type ) and $type eq "blob" )
2601         {
2602             $log->warn("Invalid type '$type' for '$name'");
2603             die ( "Invalid type '$type' (expected 'blob')" )
2604         }
2606         my $size = `git cat-file -s $name`;
2607         chomp $size;
2609         $log->debug("open_blob_or_die($name) size=$size, type=$type");
2611         unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2612         {
2613             $log->warn("Unable to open sha1 $name");
2614             die "Unable to open sha1 $name\n";
2615         }
2616     }
2617     else
2618     {
2619         $log->warn("Unknown type of blob source: $srcType");
2620         die "Unknown type of blob source: $srcType\n";
2621     }
2622     return $fh;
2625 # Generate a CVS author name from Git author information, by taking the local
2626 # part of the email address and replacing characters not in the Portable
2627 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2628 # Login names are Unix login names, which should be restricted to this
2629 # character set.
2630 sub cvs_author
2632     my $author_line = shift;
2633     (my $author) = $author_line =~ /<([^@>]*)/;
2635     $author =~ s/[^-a-zA-Z0-9_.]/_/g;
2636     $author =~ s/^-/_/;
2638     $author;
2642 sub descramble
2644     # This table is from src/scramble.c in the CVS source
2645     my @SHIFTS = (
2646         0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15,
2647         16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
2648         114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
2649         111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
2650         41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
2651         125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
2652         36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
2653         58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
2654         225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
2655         199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
2656         174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
2657         207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
2658         192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
2659         227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
2660         182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
2661         243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
2662     );
2663     my ($str) = @_;
2665     # This should never happen, the same password format (A) has been
2666     # used by CVS since the beginning of time
2667     {
2668         my $fmt = substr($str, 0, 1);
2669         die "invalid password format `$fmt'" unless $fmt eq 'A';
2670     }
2672     my @str = unpack "C*", substr($str, 1);
2673     my $ret = join '', map { chr $SHIFTS[$_] } @str;
2674     return $ret;
2678 package GITCVS::log;
2680 ####
2681 #### Copyright The Open University UK - 2006.
2682 ####
2683 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2684 ####          Martin Langhoff <martin@laptop.org>
2685 ####
2686 ####
2688 use strict;
2689 use warnings;
2691 =head1 NAME
2693 GITCVS::log
2695 =head1 DESCRIPTION
2697 This module provides very crude logging with a similar interface to
2698 Log::Log4perl
2700 =head1 METHODS
2702 =cut
2704 =head2 new
2706 Creates a new log object, optionally you can specify a filename here to
2707 indicate the file to log to. If no log file is specified, you can specify one
2708 later with method setfile, or indicate you no longer want logging with method
2709 nofile.
2711 Until one of these methods is called, all log calls will buffer messages ready
2712 to write out.
2714 =cut
2715 sub new
2717     my $class = shift;
2718     my $filename = shift;
2720     my $self = {};
2722     bless $self, $class;
2724     if ( defined ( $filename ) )
2725     {
2726         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2727     }
2729     return $self;
2732 =head2 setfile
2734 This methods takes a filename, and attempts to open that file as the log file.
2735 If successful, all buffered data is written out to the file, and any further
2736 logging is written directly to the file.
2738 =cut
2739 sub setfile
2741     my $self = shift;
2742     my $filename = shift;
2744     if ( defined ( $filename ) )
2745     {
2746         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2747     }
2749     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2751     while ( my $line = shift @{$self->{buffer}} )
2752     {
2753         print {$self->{fh}} $line;
2754     }
2757 =head2 nofile
2759 This method indicates no logging is going to be used. It flushes any entries in
2760 the internal buffer, and sets a flag to ensure no further data is put there.
2762 =cut
2763 sub nofile
2765     my $self = shift;
2767     $self->{nolog} = 1;
2769     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2771     $self->{buffer} = [];
2774 =head2 _logopen
2776 Internal method. Returns true if the log file is open, false otherwise.
2778 =cut
2779 sub _logopen
2781     my $self = shift;
2783     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2784     return 0;
2787 =head2 debug info warn fatal
2789 These four methods are wrappers to _log. They provide the actual interface for
2790 logging data.
2792 =cut
2793 sub debug { my $self = shift; $self->_log("debug", @_); }
2794 sub info  { my $self = shift; $self->_log("info" , @_); }
2795 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2796 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2798 =head2 _log
2800 This is an internal method called by the logging functions. It generates a
2801 timestamp and pushes the logged line either to file, or internal buffer.
2803 =cut
2804 sub _log
2806     my $self = shift;
2807     my $level = shift;
2809     return if ( $self->{nolog} );
2811     my @time = localtime;
2812     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2813         $time[5] + 1900,
2814         $time[4] + 1,
2815         $time[3],
2816         $time[2],
2817         $time[1],
2818         $time[0],
2819         uc $level,
2820     );
2822     if ( $self->_logopen )
2823     {
2824         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2825     } else {
2826         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2827     }
2830 =head2 DESTROY
2832 This method simply closes the file handle if one is open
2834 =cut
2835 sub DESTROY
2837     my $self = shift;
2839     if ( $self->_logopen )
2840     {
2841         close $self->{fh};
2842     }
2845 package GITCVS::updater;
2847 ####
2848 #### Copyright The Open University UK - 2006.
2849 ####
2850 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2851 ####          Martin Langhoff <martin@laptop.org>
2852 ####
2853 ####
2855 use strict;
2856 use warnings;
2857 use DBI;
2859 =head1 METHODS
2861 =cut
2863 =head2 new
2865 =cut
2866 sub new
2868     my $class = shift;
2869     my $config = shift;
2870     my $module = shift;
2871     my $log = shift;
2873     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2874     die "Need to specify a module" unless ( defined($module) );
2876     $class = ref($class) || $class;
2878     my $self = {};
2880     bless $self, $class;
2882     $self->{valid_tables} = {'revision' => 1,
2883                              'revision_ix1' => 1,
2884                              'revision_ix2' => 1,
2885                              'head' => 1,
2886                              'head_ix1' => 1,
2887                              'properties' => 1,
2888                              'commitmsgs' => 1};
2890     $self->{module} = $module;
2891     $self->{git_path} = $config . "/";
2893     $self->{log} = $log;
2895     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2897     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2898         $cfg->{gitcvs}{dbdriver} || "SQLite";
2899     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2900         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2901     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2902         $cfg->{gitcvs}{dbuser} || "";
2903     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2904         $cfg->{gitcvs}{dbpass} || "";
2905     $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2906         $cfg->{gitcvs}{dbtablenameprefix} || "";
2907     my %mapping = ( m => $module,
2908                     a => $state->{method},
2909                     u => getlogin || getpwuid($<) || $<,
2910                     G => $self->{git_path},
2911                     g => mangle_dirname($self->{git_path}),
2912                     );
2913     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2914     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2915     $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2916     $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2918     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2919     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2920     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2921                                 $self->{dbuser},
2922                                 $self->{dbpass});
2923     die "Error connecting to database\n" unless defined $self->{dbh};
2925     $self->{tables} = {};
2926     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2927     {
2928         $self->{tables}{$table} = 1;
2929     }
2931     # Construct the revision table if required
2932     unless ( $self->{tables}{$self->tablename("revision")} )
2933     {
2934         my $tablename = $self->tablename("revision");
2935         my $ix1name = $self->tablename("revision_ix1");
2936         my $ix2name = $self->tablename("revision_ix2");
2937         $self->{dbh}->do("
2938             CREATE TABLE $tablename (
2939                 name       TEXT NOT NULL,
2940                 revision   INTEGER NOT NULL,
2941                 filehash   TEXT NOT NULL,
2942                 commithash TEXT NOT NULL,
2943                 author     TEXT NOT NULL,
2944                 modified   TEXT NOT NULL,
2945                 mode       TEXT NOT NULL
2946             )
2947         ");
2948         $self->{dbh}->do("
2949             CREATE INDEX $ix1name
2950             ON $tablename (name,revision)
2951         ");
2952         $self->{dbh}->do("
2953             CREATE INDEX $ix2name
2954             ON $tablename (name,commithash)
2955         ");
2956     }
2958     # Construct the head table if required
2959     unless ( $self->{tables}{$self->tablename("head")} )
2960     {
2961         my $tablename = $self->tablename("head");
2962         my $ix1name = $self->tablename("head_ix1");
2963         $self->{dbh}->do("
2964             CREATE TABLE $tablename (
2965                 name       TEXT NOT NULL,
2966                 revision   INTEGER NOT NULL,
2967                 filehash   TEXT NOT NULL,
2968                 commithash TEXT NOT NULL,
2969                 author     TEXT NOT NULL,
2970                 modified   TEXT NOT NULL,
2971                 mode       TEXT NOT NULL
2972             )
2973         ");
2974         $self->{dbh}->do("
2975             CREATE INDEX $ix1name
2976             ON $tablename (name)
2977         ");
2978     }
2980     # Construct the properties table if required
2981     unless ( $self->{tables}{$self->tablename("properties")} )
2982     {
2983         my $tablename = $self->tablename("properties");
2984         $self->{dbh}->do("
2985             CREATE TABLE $tablename (
2986                 key        TEXT NOT NULL PRIMARY KEY,
2987                 value      TEXT
2988             )
2989         ");
2990     }
2992     # Construct the commitmsgs table if required
2993     unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2994     {
2995         my $tablename = $self->tablename("commitmsgs");
2996         $self->{dbh}->do("
2997             CREATE TABLE $tablename (
2998                 key        TEXT NOT NULL PRIMARY KEY,
2999                 value      TEXT
3000             )
3001         ");
3002     }
3004     return $self;
3007 =head2 tablename
3009 =cut
3010 sub tablename
3012     my $self = shift;
3013     my $name = shift;
3015     if (exists $self->{valid_tables}{$name}) {
3016         return $self->{dbtablenameprefix} . $name;
3017     } else {
3018         return undef;
3019     }
3022 =head2 update
3024 =cut
3025 sub update
3027     my $self = shift;
3029     # first lets get the commit list
3030     $ENV{GIT_DIR} = $self->{git_path};
3032     my $commitsha1 = `git rev-parse $self->{module}`;
3033     chomp $commitsha1;
3035     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
3036     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3037     {
3038         die("Invalid module '$self->{module}'");
3039     }
3042     my $git_log;
3043     my $lastcommit = $self->_get_prop("last_commit");
3045     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
3046          return 1;
3047     }
3049     # Start exclusive lock here...
3050     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3052     # TODO: log processing is memory bound
3053     # if we can parse into a 2nd file that is in reverse order
3054     # we can probably do something really efficient
3055     my @git_log_params = ('--pretty', '--parents', '--topo-order');
3057     if (defined $lastcommit) {
3058         push @git_log_params, "$lastcommit..$self->{module}";
3059     } else {
3060         push @git_log_params, $self->{module};
3061     }
3062     # git-rev-list is the backend / plumbing version of git-log
3063     open(GITLOG, '-|', 'git', 'rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
3065     my @commits;
3067     my %commit = ();
3069     while ( <GITLOG> )
3070     {
3071         chomp;
3072         if (m/^commit\s+(.*)$/) {
3073             # on ^commit lines put the just seen commit in the stack
3074             # and prime things for the next one
3075             if (keys %commit) {
3076                 my %copy = %commit;
3077                 unshift @commits, \%copy;
3078                 %commit = ();
3079             }
3080             my @parents = split(m/\s+/, $1);
3081             $commit{hash} = shift @parents;
3082             $commit{parents} = \@parents;
3083         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
3084             # on rfc822-like lines seen before we see any message,
3085             # lowercase the entry and put it in the hash as key-value
3086             $commit{lc($1)} = $2;
3087         } else {
3088             # message lines - skip initial empty line
3089             # and trim whitespace
3090             if (!exists($commit{message}) && m/^\s*$/) {
3091                 # define it to mark the end of headers
3092                 $commit{message} = '';
3093                 next;
3094             }
3095             s/^\s+//; s/\s+$//; # trim ws
3096             $commit{message} .= $_ . "\n";
3097         }
3098     }
3099     close GITLOG;
3101     unshift @commits, \%commit if ( keys %commit );
3103     # Now all the commits are in the @commits bucket
3104     # ordered by time DESC. for each commit that needs processing,
3105     # determine whether it's following the last head we've seen or if
3106     # it's on its own branch, grab a file list, and add whatever's changed
3107     # NOTE: $lastcommit refers to the last commit from previous run
3108     #       $lastpicked is the last commit we picked in this run
3109     my $lastpicked;
3110     my $head = {};
3111     if (defined $lastcommit) {
3112         $lastpicked = $lastcommit;
3113     }
3115     my $committotal = scalar(@commits);
3116     my $commitcount = 0;
3118     # Load the head table into $head (for cached lookups during the update process)
3119     foreach my $file ( @{$self->gethead()} )
3120     {
3121         $head->{$file->{name}} = $file;
3122     }
3124     foreach my $commit ( @commits )
3125     {
3126         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3127         if (defined $lastpicked)
3128         {
3129             if (!in_array($lastpicked, @{$commit->{parents}}))
3130             {
3131                 # skip, we'll see this delta
3132                 # as part of a merge later
3133                 # warn "skipping off-track  $commit->{hash}\n";
3134                 next;
3135             } elsif (@{$commit->{parents}} > 1) {
3136                 # it is a merge commit, for each parent that is
3137                 # not $lastpicked, see if we can get a log
3138                 # from the merge-base to that parent to put it
3139                 # in the message as a merge summary.
3140                 my @parents = @{$commit->{parents}};
3141                 foreach my $parent (@parents) {
3142                     # git-merge-base can potentially (but rarely) throw
3143                     # several candidate merge bases. let's assume
3144                     # that the first one is the best one.
3145                     if ($parent eq $lastpicked) {
3146                         next;
3147                     }
3148                     my $base = eval {
3149                             safe_pipe_capture('git', 'merge-base',
3150                                                  $lastpicked, $parent);
3151                     };
3152                     # The two branches may not be related at all,
3153                     # in which case merge base simply fails to find
3154                     # any, but that's Ok.
3155                     next if ($@);
3157                     chomp $base;
3158                     if ($base) {
3159                         my @merged;
3160                         # print "want to log between  $base $parent \n";
3161                         open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
3162                           or die "Cannot call git-log: $!";
3163                         my $mergedhash;
3164                         while (<GITLOG>) {
3165                             chomp;
3166                             if (!defined $mergedhash) {
3167                                 if (m/^commit\s+(.+)$/) {
3168                                     $mergedhash = $1;
3169                                 } else {
3170                                     next;
3171                                 }
3172                             } else {
3173                                 # grab the first line that looks non-rfc822
3174                                 # aka has content after leading space
3175                                 if (m/^\s+(\S.*)$/) {
3176                                     my $title = $1;
3177                                     $title = substr($title,0,100); # truncate
3178                                     unshift @merged, "$mergedhash $title";
3179                                     undef $mergedhash;
3180                                 }
3181                             }
3182                         }
3183                         close GITLOG;
3184                         if (@merged) {
3185                             $commit->{mergemsg} = $commit->{message};
3186                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3187                             foreach my $summary (@merged) {
3188                                 $commit->{mergemsg} .= "\t$summary\n";
3189                             }
3190                             $commit->{mergemsg} .= "\n\n";
3191                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3192                         }
3193                     }
3194                 }
3195             }
3196         }
3198         # convert the date to CVS-happy format
3199         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3201         if ( defined ( $lastpicked ) )
3202         {
3203             my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3204             local ($/) = "\0";
3205             while ( <FILELIST> )
3206             {
3207                 chomp;
3208                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3209                 {
3210                     die("Couldn't process git-diff-tree line : $_");
3211                 }
3212                 my ($mode, $hash, $change) = ($1, $2, $3);
3213                 my $name = <FILELIST>;
3214                 chomp($name);
3216                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3218                 my $git_perms = "";
3219                 $git_perms .= "r" if ( $mode & 4 );
3220                 $git_perms .= "w" if ( $mode & 2 );
3221                 $git_perms .= "x" if ( $mode & 1 );
3222                 $git_perms = "rw" if ( $git_perms eq "" );
3224                 if ( $change eq "D" )
3225                 {
3226                     #$log->debug("DELETE   $name");
3227                     $head->{$name} = {
3228                         name => $name,
3229                         revision => $head->{$name}{revision} + 1,
3230                         filehash => "deleted",
3231                         commithash => $commit->{hash},
3232                         modified => $commit->{date},
3233                         author => $commit->{author},
3234                         mode => $git_perms,
3235                     };
3236                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3237                 }
3238                 elsif ( $change eq "M" || $change eq "T" )
3239                 {
3240                     #$log->debug("MODIFIED $name");
3241                     $head->{$name} = {
3242                         name => $name,
3243                         revision => $head->{$name}{revision} + 1,
3244                         filehash => $hash,
3245                         commithash => $commit->{hash},
3246                         modified => $commit->{date},
3247                         author => $commit->{author},
3248                         mode => $git_perms,
3249                     };
3250                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3251                 }
3252                 elsif ( $change eq "A" )
3253                 {
3254                     #$log->debug("ADDED    $name");
3255                     $head->{$name} = {
3256                         name => $name,
3257                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3258                         filehash => $hash,
3259                         commithash => $commit->{hash},
3260                         modified => $commit->{date},
3261                         author => $commit->{author},
3262                         mode => $git_perms,
3263                     };
3264                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3265                 }
3266                 else
3267                 {
3268                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3269                     die;
3270                 }
3271             }
3272             close FILELIST;
3273         } else {
3274             # this is used to detect files removed from the repo
3275             my $seen_files = {};
3277             my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3278             local $/ = "\0";
3279             while ( <FILELIST> )
3280             {
3281                 chomp;
3282                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3283                 {
3284                     die("Couldn't process git-ls-tree line : $_");
3285                 }
3287                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3289                 $seen_files->{$git_filename} = 1;
3291                 my ( $oldhash, $oldrevision, $oldmode ) = (
3292                     $head->{$git_filename}{filehash},
3293                     $head->{$git_filename}{revision},
3294                     $head->{$git_filename}{mode}
3295                 );
3297                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3298                 {
3299                     $git_perms = "";
3300                     $git_perms .= "r" if ( $1 & 4 );
3301                     $git_perms .= "w" if ( $1 & 2 );
3302                     $git_perms .= "x" if ( $1 & 1 );
3303                 } else {
3304                     $git_perms = "rw";
3305                 }
3307                 # unless the file exists with the same hash, we need to update it ...
3308                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3309                 {
3310                     my $newrevision = ( $oldrevision or 0 ) + 1;
3312                     $head->{$git_filename} = {
3313                         name => $git_filename,
3314                         revision => $newrevision,
3315                         filehash => $git_hash,
3316                         commithash => $commit->{hash},
3317                         modified => $commit->{date},
3318                         author => $commit->{author},
3319                         mode => $git_perms,
3320                     };
3323                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3324                 }
3325             }
3326             close FILELIST;
3328             # Detect deleted files
3329             foreach my $file ( keys %$head )
3330             {
3331                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3332                 {
3333                     $head->{$file}{revision}++;
3334                     $head->{$file}{filehash} = "deleted";
3335                     $head->{$file}{commithash} = $commit->{hash};
3336                     $head->{$file}{modified} = $commit->{date};
3337                     $head->{$file}{author} = $commit->{author};
3339                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3340                 }
3341             }
3342             # END : "Detect deleted files"
3343         }
3346         if (exists $commit->{mergemsg})
3347         {
3348             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3349         }
3351         $lastpicked = $commit->{hash};
3353         $self->_set_prop("last_commit", $commit->{hash});
3354     }
3356     $self->delete_head();
3357     foreach my $file ( keys %$head )
3358     {
3359         $self->insert_head(
3360             $file,
3361             $head->{$file}{revision},
3362             $head->{$file}{filehash},
3363             $head->{$file}{commithash},
3364             $head->{$file}{modified},
3365             $head->{$file}{author},
3366             $head->{$file}{mode},
3367         );
3368     }
3369     # invalidate the gethead cache
3370     $self->{gethead_cache} = undef;
3373     # Ending exclusive lock here
3374     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3377 sub insert_rev
3379     my $self = shift;
3380     my $name = shift;
3381     my $revision = shift;
3382     my $filehash = shift;
3383     my $commithash = shift;
3384     my $modified = shift;
3385     my $author = shift;
3386     my $mode = shift;
3387     my $tablename = $self->tablename("revision");
3389     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3390     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3393 sub insert_mergelog
3395     my $self = shift;
3396     my $key = shift;
3397     my $value = shift;
3398     my $tablename = $self->tablename("commitmsgs");
3400     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3401     $insert_mergelog->execute($key, $value);
3404 sub delete_head
3406     my $self = shift;
3407     my $tablename = $self->tablename("head");
3409     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3410     $delete_head->execute();
3413 sub insert_head
3415     my $self = shift;
3416     my $name = shift;
3417     my $revision = shift;
3418     my $filehash = shift;
3419     my $commithash = shift;
3420     my $modified = shift;
3421     my $author = shift;
3422     my $mode = shift;
3423     my $tablename = $self->tablename("head");
3425     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3426     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3429 sub _headrev
3431     my $self = shift;
3432     my $filename = shift;
3433     my $tablename = $self->tablename("head");
3435     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3436     $db_query->execute($filename);
3437     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3439     return ( $hash, $revision, $mode );
3442 sub _get_prop
3444     my $self = shift;
3445     my $key = shift;
3446     my $tablename = $self->tablename("properties");
3448     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3449     $db_query->execute($key);
3450     my ( $value ) = $db_query->fetchrow_array;
3452     return $value;
3455 sub _set_prop
3457     my $self = shift;
3458     my $key = shift;
3459     my $value = shift;
3460     my $tablename = $self->tablename("properties");
3462     my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3463     $db_query->execute($value, $key);
3465     unless ( $db_query->rows )
3466     {
3467         $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3468         $db_query->execute($key, $value);
3469     }
3471     return $value;
3474 =head2 gethead
3476 =cut
3478 sub gethead
3480     my $self = shift;
3481     my $tablename = $self->tablename("head");
3483     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3485     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3486     $db_query->execute();
3488     my $tree = [];
3489     while ( my $file = $db_query->fetchrow_hashref )
3490     {
3491         push @$tree, $file;
3492     }
3494     $self->{gethead_cache} = $tree;
3496     return $tree;
3499 =head2 getlog
3501 =cut
3503 sub getlog
3505     my $self = shift;
3506     my $filename = shift;
3507     my $tablename = $self->tablename("revision");
3509     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3510     $db_query->execute($filename);
3512     my $tree = [];
3513     while ( my $file = $db_query->fetchrow_hashref )
3514     {
3515         push @$tree, $file;
3516     }
3518     return $tree;
3521 =head2 getmeta
3523 This function takes a filename (with path) argument and returns a hashref of
3524 metadata for that file.
3526 =cut
3528 sub getmeta
3530     my $self = shift;
3531     my $filename = shift;
3532     my $revision = shift;
3533     my $tablename_rev = $self->tablename("revision");
3534     my $tablename_head = $self->tablename("head");
3536     my $db_query;
3537     if ( defined($revision) and $revision =~ /^\d+$/ )
3538     {
3539         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3540         $db_query->execute($filename, $revision);
3541     }
3542     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3543     {
3544         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3545         $db_query->execute($filename, $revision);
3546     } else {
3547         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3548         $db_query->execute($filename);
3549     }
3551     return $db_query->fetchrow_hashref;
3554 =head2 commitmessage
3556 this function takes a commithash and returns the commit message for that commit
3558 =cut
3559 sub commitmessage
3561     my $self = shift;
3562     my $commithash = shift;
3563     my $tablename = $self->tablename("commitmsgs");
3565     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3567     my $db_query;
3568     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3569     $db_query->execute($commithash);
3571     my ( $message ) = $db_query->fetchrow_array;
3573     if ( defined ( $message ) )
3574     {
3575         $message .= " " if ( $message =~ /\n$/ );
3576         return $message;
3577     }
3579     my @lines = safe_pipe_capture("git", "cat-file", "commit", $commithash);
3580     shift @lines while ( $lines[0] =~ /\S/ );
3581     $message = join("",@lines);
3582     $message .= " " if ( $message =~ /\n$/ );
3583     return $message;
3586 =head2 gethistory
3588 This function takes a filename (with path) argument and returns an arrayofarrays
3589 containing revision,filehash,commithash ordered by revision descending
3591 =cut
3592 sub gethistory
3594     my $self = shift;
3595     my $filename = shift;
3596     my $tablename = $self->tablename("revision");
3598     my $db_query;
3599     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3600     $db_query->execute($filename);
3602     return $db_query->fetchall_arrayref;
3605 =head2 gethistorydense
3607 This function takes a filename (with path) argument and returns an arrayofarrays
3608 containing revision,filehash,commithash ordered by revision descending.
3610 This version of gethistory skips deleted entries -- so it is useful for annotate.
3611 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3612 and other git tools that depend on it.
3614 =cut
3615 sub gethistorydense
3617     my $self = shift;
3618     my $filename = shift;
3619     my $tablename = $self->tablename("revision");
3621     my $db_query;
3622     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3623     $db_query->execute($filename);
3625     return $db_query->fetchall_arrayref;
3628 =head2 in_array()
3630 from Array::PAT - mimics the in_array() function
3631 found in PHP. Yuck but works for small arrays.
3633 =cut
3634 sub in_array
3636     my ($check, @array) = @_;
3637     my $retval = 0;
3638     foreach my $test (@array){
3639         if($check eq $test){
3640             $retval =  1;
3641         }
3642     }
3643     return $retval;
3646 =head2 safe_pipe_capture
3648 an alternative to `command` that allows input to be passed as an array
3649 to work around shell problems with weird characters in arguments
3651 =cut
3652 sub safe_pipe_capture {
3654     my @output;
3656     if (my $pid = open my $child, '-|') {
3657         @output = (<$child>);
3658         close $child or die join(' ',@_).": $! $?";
3659     } else {
3660         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3661     }
3662     return wantarray ? @output : join('',@output);
3665 =head2 mangle_dirname
3667 create a string from a directory name that is suitable to use as
3668 part of a filename, mainly by converting all chars except \w.- to _
3670 =cut
3671 sub mangle_dirname {
3672     my $dirname = shift;
3673     return unless defined $dirname;
3675     $dirname =~ s/[^\w.-]/_/g;
3677     return $dirname;
3680 =head2 mangle_tablename
3682 create a string from a that is suitable to use as part of an SQL table
3683 name, mainly by converting all chars except \w to _
3685 =cut
3686 sub mangle_tablename {
3687     my $tablename = shift;
3688     return unless defined $tablename;
3690     $tablename =~ s/[^\w_]/_/g;
3692     return $tablename;
3695 1;