Code

Merge branch 'maint'
[git.git] / git-cvsserver.perl
1 #!/usr/bin/perl
3 ####
4 #### This application is a CVS emulation layer for git.
5 #### It is intended for clients to connect over SSH.
6 #### See the documentation for more details.
7 ####
8 #### Copyright The Open University UK - 2006.
9 ####
10 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
11 ####          Martin Langhoff <martin@catalyst.net.nz>
12 ####
13 ####
14 #### Released under the GNU Public License, version 2.
15 ####
16 ####
18 use strict;
19 use warnings;
20 use bytes;
22 use Fcntl;
23 use File::Temp qw/tempdir tempfile/;
24 use File::Path qw/rmtree/;
25 use File::Basename;
26 use Getopt::Long qw(:config require_order no_ignore_case);
28 my $VERSION = '@@GIT_VERSION@@';
30 my $log = GITCVS::log->new();
31 my $cfg;
33 my $DATE_LIST = {
34     Jan => "01",
35     Feb => "02",
36     Mar => "03",
37     Apr => "04",
38     May => "05",
39     Jun => "06",
40     Jul => "07",
41     Aug => "08",
42     Sep => "09",
43     Oct => "10",
44     Nov => "11",
45     Dec => "12",
46 };
48 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
49 $| = 1;
51 #### Definition and mappings of functions ####
53 my $methods = {
54     'Root'            => \&req_Root,
55     'Valid-responses' => \&req_Validresponses,
56     'valid-requests'  => \&req_validrequests,
57     'Directory'       => \&req_Directory,
58     'Entry'           => \&req_Entry,
59     'Modified'        => \&req_Modified,
60     'Unchanged'       => \&req_Unchanged,
61     'Questionable'    => \&req_Questionable,
62     'Argument'        => \&req_Argument,
63     'Argumentx'       => \&req_Argument,
64     'expand-modules'  => \&req_expandmodules,
65     'add'             => \&req_add,
66     'remove'          => \&req_remove,
67     'co'              => \&req_co,
68     'update'          => \&req_update,
69     'ci'              => \&req_ci,
70     'diff'            => \&req_diff,
71     'log'             => \&req_log,
72     'rlog'            => \&req_log,
73     'tag'             => \&req_CATCHALL,
74     'status'          => \&req_status,
75     'admin'           => \&req_CATCHALL,
76     'history'         => \&req_CATCHALL,
77     'watchers'        => \&req_EMPTY,
78     'editors'         => \&req_EMPTY,
79     'annotate'        => \&req_annotate,
80     'Global_option'   => \&req_Globaloption,
81     #'annotate'        => \&req_CATCHALL,
82 };
84 ##############################################
87 # $state holds all the bits of information the clients sends us that could
88 # potentially be useful when it comes to actually _doing_ something.
89 my $state = { prependdir => '' };
91 # Work is for managing temporary working directory
92 my $work =
93     {
94         state => undef,  # undef, 1 (empty), 2 (with stuff)
95         workDir => undef,
96         index => undef,
97         emptyDir => undef,
98         tmpDir => undef
99     };
101 $log->info("--------------- STARTING -----------------");
103 my $usage =
104     "Usage: git-cvsserver [options] [pserver|server] [<directory> ...]\n".
105     "    --base-path <path>  : Prepend to requested CVSROOT\n".
106     "    --strict-paths      : Don't allow recursing into subdirectories\n".
107     "    --export-all        : Don't check for gitcvs.enabled in config\n".
108     "    --version, -V       : Print version information and exit\n".
109     "    --help, -h, -H      : Print usage information and exit\n".
110     "\n".
111     "<directory> ... is a list of allowed directories. If no directories\n".
112     "are given, all are allowed. This is an additional restriction, gitcvs\n".
113     "access still needs to be enabled by the gitcvs.enabled config option.\n";
115 my @opts = ( 'help|h|H', 'version|V',
116              'base-path=s', 'strict-paths', 'export-all' );
117 GetOptions( $state, @opts )
118     or die $usage;
120 if ($state->{version}) {
121     print "git-cvsserver version $VERSION\n";
122     exit;
124 if ($state->{help}) {
125     print $usage;
126     exit;
129 my $TEMP_DIR = tempdir( CLEANUP => 1 );
130 $log->debug("Temporary directory is '$TEMP_DIR'");
132 $state->{method} = 'ext';
133 if (@ARGV) {
134     if ($ARGV[0] eq 'pserver') {
135         $state->{method} = 'pserver';
136         shift @ARGV;
137     } elsif ($ARGV[0] eq 'server') {
138         shift @ARGV;
139     }
142 # everything else is a directory
143 $state->{allowed_roots} = [ @ARGV ];
145 # don't export the whole system unless the users requests it
146 if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
147     die "--export-all can only be used together with an explicit whitelist\n";
150 # if we are called with a pserver argument,
151 # deal with the authentication cat before entering the
152 # main loop
153 if ($state->{method} eq 'pserver') {
154     my $line = <STDIN>; chomp $line;
155     unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
156        die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
157     }
158     my $request = $1;
159     $line = <STDIN>; chomp $line;
160     unless (req_Root('root', $line)) { # reuse Root
161        print "E Invalid root $line \n";
162        exit 1;
163     }
164     $line = <STDIN>; chomp $line;
165     unless ($line eq 'anonymous') {
166        print "E Only anonymous user allowed via pserver\n";
167        print "I HATE YOU\n";
168        exit 1;
169     }
170     $line = <STDIN>; chomp $line;    # validate the password?
171     $line = <STDIN>; chomp $line;
172     unless ($line eq "END $request REQUEST") {
173        die "E Do not understand $line -- expecting END $request REQUEST\n";
174     }
175     print "I LOVE YOU\n";
176     exit if $request eq 'VERIFICATION'; # cvs login
177     # and now back to our regular programme...
180 # Keep going until the client closes the connection
181 while (<STDIN>)
183     chomp;
185     # Check to see if we've seen this method, and call appropriate function.
186     if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
187     {
188         # use the $methods hash to call the appropriate sub for this command
189         #$log->info("Method : $1");
190         &{$methods->{$1}}($1,$2);
191     } else {
192         # log fatal because we don't understand this function. If this happens
193         # we're fairly screwed because we don't know if the client is expecting
194         # a response. If it is, the client will hang, we'll hang, and the whole
195         # thing will be custard.
196         $log->fatal("Don't understand command $_\n");
197         die("Unknown command $_");
198     }
201 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
202 $log->info("--------------- FINISH -----------------");
204 chdir '/';
205 exit 0;
207 # Magic catchall method.
208 #    This is the method that will handle all commands we haven't yet
209 #    implemented. It simply sends a warning to the log file indicating a
210 #    command that hasn't been implemented has been invoked.
211 sub req_CATCHALL
213     my ( $cmd, $data ) = @_;
214     $log->warn("Unhandled command : req_$cmd : $data");
217 # This method invariably succeeds with an empty response.
218 sub req_EMPTY
220     print "ok\n";
223 # Root pathname \n
224 #     Response expected: no. Tell the server which CVSROOT to use. Note that
225 #     pathname is a local directory and not a fully qualified CVSROOT variable.
226 #     pathname must already exist; if creating a new root, use the init
227 #     request, not Root. pathname does not include the hostname of the server,
228 #     how to access the server, etc.; by the time the CVS protocol is in use,
229 #     connection, authentication, etc., are already taken care of. The Root
230 #     request must be sent only once, and it must be sent before any requests
231 #     other than Valid-responses, valid-requests, UseUnchanged, Set or init.
232 sub req_Root
234     my ( $cmd, $data ) = @_;
235     $log->debug("req_Root : $data");
237     unless ($data =~ m#^/#) {
238         print "error 1 Root must be an absolute pathname\n";
239         return 0;
240     }
242     my $cvsroot = $state->{'base-path'} || '';
243     $cvsroot =~ s#/+$##;
244     $cvsroot .= $data;
246     if ($state->{CVSROOT}
247         && ($state->{CVSROOT} ne $cvsroot)) {
248         print "error 1 Conflicting roots specified\n";
249         return 0;
250     }
252     $state->{CVSROOT} = $cvsroot;
254     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
256     if (@{$state->{allowed_roots}}) {
257         my $allowed = 0;
258         foreach my $dir (@{$state->{allowed_roots}}) {
259             next unless $dir =~ m#^/#;
260             $dir =~ s#/+$##;
261             if ($state->{'strict-paths'}) {
262                 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
263                     $allowed = 1;
264                     last;
265                 }
266             } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
267                 $allowed = 1;
268                 last;
269             }
270         }
272         unless ($allowed) {
273             print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
274             print "E \n";
275             print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
276             return 0;
277         }
278     }
280     unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
281        print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
282        print "E \n";
283        print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
284        return 0;
285     }
287     my @gitvars = `git-config -l`;
288     if ($?) {
289        print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
290         print "E \n";
291         print "error 1 - problem executing git-config\n";
292        return 0;
293     }
294     foreach my $line ( @gitvars )
295     {
296         next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
297         unless ($2) {
298             $cfg->{$1}{$3} = $4;
299         } else {
300             $cfg->{$1}{$2}{$3} = $4;
301         }
302     }
304     my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
305                    || $cfg->{gitcvs}{enabled});
306     unless ($state->{'export-all'} ||
307             ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
308         print "E GITCVS emulation needs to be enabled on this repo\n";
309         print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
310         print "E \n";
311         print "error 1 GITCVS emulation disabled\n";
312         return 0;
313     }
315     my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
316     if ( $logfile )
317     {
318         $log->setfile($logfile);
319     } else {
320         $log->nofile();
321     }
323     return 1;
326 # Global_option option \n
327 #     Response expected: no. Transmit one of the global options `-q', `-Q',
328 #     `-l', `-t', `-r', or `-n'. option must be one of those strings, no
329 #     variations (such as combining of options) are allowed. For graceful
330 #     handling of valid-requests, it is probably better to make new global
331 #     options separate requests, rather than trying to add them to this
332 #     request.
333 sub req_Globaloption
335     my ( $cmd, $data ) = @_;
336     $log->debug("req_Globaloption : $data");
337     $state->{globaloptions}{$data} = 1;
340 # Valid-responses request-list \n
341 #     Response expected: no. Tell the server what responses the client will
342 #     accept. request-list is a space separated list of tokens.
343 sub req_Validresponses
345     my ( $cmd, $data ) = @_;
346     $log->debug("req_Validresponses : $data");
348     # TODO : re-enable this, currently it's not particularly useful
349     #$state->{validresponses} = [ split /\s+/, $data ];
352 # valid-requests \n
353 #     Response expected: yes. Ask the server to send back a Valid-requests
354 #     response.
355 sub req_validrequests
357     my ( $cmd, $data ) = @_;
359     $log->debug("req_validrequests");
361     $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
362     $log->debug("SEND : ok");
364     print "Valid-requests " . join(" ",keys %$methods) . "\n";
365     print "ok\n";
368 # Directory local-directory \n
369 #     Additional data: repository \n. Response expected: no. Tell the server
370 #     what directory to use. The repository should be a directory name from a
371 #     previous server response. Note that this both gives a default for Entry
372 #     and Modified and also for ci and the other commands; normal usage is to
373 #     send Directory for each directory in which there will be an Entry or
374 #     Modified, and then a final Directory for the original directory, then the
375 #     command. The local-directory is relative to the top level at which the
376 #     command is occurring (i.e. the last Directory which is sent before the
377 #     command); to indicate that top level, `.' should be sent for
378 #     local-directory.
379 sub req_Directory
381     my ( $cmd, $data ) = @_;
383     my $repository = <STDIN>;
384     chomp $repository;
387     $state->{localdir} = $data;
388     $state->{repository} = $repository;
389     $state->{path} = $repository;
390     $state->{path} =~ s/^$state->{CVSROOT}\///;
391     $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
392     $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
394     $state->{directory} = $state->{localdir};
395     $state->{directory} = "" if ( $state->{directory} eq "." );
396     $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
398     if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
399     {
400         $log->info("Setting prepend to '$state->{path}'");
401         $state->{prependdir} = $state->{path};
402         foreach my $entry ( keys %{$state->{entries}} )
403         {
404             $state->{entries}{$state->{prependdir} . $entry} = $state->{entries}{$entry};
405             delete $state->{entries}{$entry};
406         }
407     }
409     if ( defined ( $state->{prependdir} ) )
410     {
411         $log->debug("Prepending '$state->{prependdir}' to state|directory");
412         $state->{directory} = $state->{prependdir} . $state->{directory}
413     }
414     $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
417 # Entry entry-line \n
418 #     Response expected: no. Tell the server what version of a file is on the
419 #     local machine. The name in entry-line is a name relative to the directory
420 #     most recently specified with Directory. If the user is operating on only
421 #     some files in a directory, Entry requests for only those files need be
422 #     included. If an Entry request is sent without Modified, Is-modified, or
423 #     Unchanged, it means the file is lost (does not exist in the working
424 #     directory). If both Entry and one of Modified, Is-modified, or Unchanged
425 #     are sent for the same file, Entry must be sent first. For a given file,
426 #     one can send Modified, Is-modified, or Unchanged, but not more than one
427 #     of these three.
428 sub req_Entry
430     my ( $cmd, $data ) = @_;
432     #$log->debug("req_Entry : $data");
434     my @data = split(/\//, $data);
436     $state->{entries}{$state->{directory}.$data[1]} = {
437         revision    => $data[2],
438         conflict    => $data[3],
439         options     => $data[4],
440         tag_or_date => $data[5],
441     };
443     $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
446 # Questionable filename \n
447 #     Response expected: no. Additional data: no. Tell the server to check
448 #     whether filename should be ignored, and if not, next time the server
449 #     sends responses, send (in a M response) `?' followed by the directory and
450 #     filename. filename must not contain `/'; it needs to be a file in the
451 #     directory named by the most recent Directory request.
452 sub req_Questionable
454     my ( $cmd, $data ) = @_;
456     $log->debug("req_Questionable : $data");
457     $state->{entries}{$state->{directory}.$data}{questionable} = 1;
460 # add \n
461 #     Response expected: yes. Add a file or directory. This uses any previous
462 #     Argument, Directory, Entry, or Modified requests, if they have been sent.
463 #     The last Directory sent specifies the working directory at the time of
464 #     the operation. To add a directory, send the directory to be added using
465 #     Directory and Argument requests.
466 sub req_add
468     my ( $cmd, $data ) = @_;
470     argsplit("add");
472     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
473     $updater->update();
475     argsfromdir($updater);
477     my $addcount = 0;
479     foreach my $filename ( @{$state->{args}} )
480     {
481         $filename = filecleanup($filename);
483         my $meta = $updater->getmeta($filename);
484         my $wrev = revparse($filename);
486         if ($wrev && $meta && ($wrev < 0))
487         {
488             # previously removed file, add back
489             $log->info("added file $filename was previously removed, send 1.$meta->{revision}");
491             print "MT +updated\n";
492             print "MT text U \n";
493             print "MT fname $filename\n";
494             print "MT newline\n";
495             print "MT -updated\n";
497             unless ( $state->{globaloptions}{-n} )
498             {
499                 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
501                 print "Created $dirpart\n";
502                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
504                 # this is an "entries" line
505                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
506                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
507                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
508                 # permissions
509                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
510                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
511                 # transmit file
512                 transmitfile($meta->{filehash});
513             }
515             next;
516         }
518         unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
519         {
520             print "E cvs add: nothing known about `$filename'\n";
521             next;
522         }
523         # TODO : check we're not squashing an already existing file
524         if ( defined ( $state->{entries}{$filename}{revision} ) )
525         {
526             print "E cvs add: `$filename' has already been entered\n";
527             next;
528         }
530         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
532         print "E cvs add: scheduling file `$filename' for addition\n";
534         print "Checked-in $dirpart\n";
535         print "$filename\n";
536         my $kopts = kopts_from_path($filename,"file",
537                         $state->{entries}{$filename}{modified_filename});
538         print "/$filepart/0//$kopts/\n";
540         my $requestedKopts = $state->{opt}{k};
541         if(defined($requestedKopts))
542         {
543             $requestedKopts = "-k$requestedKopts";
544         }
545         else
546         {
547             $requestedKopts = "";
548         }
549         if( $kopts ne $requestedKopts )
550         {
551             $log->warn("Ignoring requested -k='$requestedKopts'"
552                         . " for '$filename'; detected -k='$kopts' instead");
553             #TODO: Also have option to send warning to user?
554         }
556         $addcount++;
557     }
559     if ( $addcount == 1 )
560     {
561         print "E cvs add: use `cvs commit' to add this file permanently\n";
562     }
563     elsif ( $addcount > 1 )
564     {
565         print "E cvs add: use `cvs commit' to add these files permanently\n";
566     }
568     print "ok\n";
571 # remove \n
572 #     Response expected: yes. Remove a file. This uses any previous Argument,
573 #     Directory, Entry, or Modified requests, if they have been sent. The last
574 #     Directory sent specifies the working directory at the time of the
575 #     operation. Note that this request does not actually do anything to the
576 #     repository; the only effect of a successful remove request is to supply
577 #     the client with a new entries line containing `-' to indicate a removed
578 #     file. In fact, the client probably could perform this operation without
579 #     contacting the server, although using remove may cause the server to
580 #     perform a few more checks. The client sends a subsequent ci request to
581 #     actually record the removal in the repository.
582 sub req_remove
584     my ( $cmd, $data ) = @_;
586     argsplit("remove");
588     # Grab a handle to the SQLite db and do any necessary updates
589     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
590     $updater->update();
592     #$log->debug("add state : " . Dumper($state));
594     my $rmcount = 0;
596     foreach my $filename ( @{$state->{args}} )
597     {
598         $filename = filecleanup($filename);
600         if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
601         {
602             print "E cvs remove: file `$filename' still in working directory\n";
603             next;
604         }
606         my $meta = $updater->getmeta($filename);
607         my $wrev = revparse($filename);
609         unless ( defined ( $wrev ) )
610         {
611             print "E cvs remove: nothing known about `$filename'\n";
612             next;
613         }
615         if ( defined($wrev) and $wrev < 0 )
616         {
617             print "E cvs remove: file `$filename' already scheduled for removal\n";
618             next;
619         }
621         unless ( $wrev == $meta->{revision} )
622         {
623             # TODO : not sure if the format of this message is quite correct.
624             print "E cvs remove: Up to date check failed for `$filename'\n";
625             next;
626         }
629         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
631         print "E cvs remove: scheduling `$filename' for removal\n";
633         print "Checked-in $dirpart\n";
634         print "$filename\n";
635         my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
636         print "/$filepart/-1.$wrev//$kopts/\n";
638         $rmcount++;
639     }
641     if ( $rmcount == 1 )
642     {
643         print "E cvs remove: use `cvs commit' to remove this file permanently\n";
644     }
645     elsif ( $rmcount > 1 )
646     {
647         print "E cvs remove: use `cvs commit' to remove these files permanently\n";
648     }
650     print "ok\n";
653 # Modified filename \n
654 #     Response expected: no. Additional data: mode, \n, file transmission. Send
655 #     the server a copy of one locally modified file. filename is a file within
656 #     the most recent directory sent with Directory; it must not contain `/'.
657 #     If the user is operating on only some files in a directory, only those
658 #     files need to be included. This can also be sent without Entry, if there
659 #     is no entry for the file.
660 sub req_Modified
662     my ( $cmd, $data ) = @_;
664     my $mode = <STDIN>;
665     defined $mode
666         or (print "E end of file reading mode for $data\n"), return;
667     chomp $mode;
668     my $size = <STDIN>;
669     defined $size
670         or (print "E end of file reading size of $data\n"), return;
671     chomp $size;
673     # Grab config information
674     my $blocksize = 8192;
675     my $bytesleft = $size;
676     my $tmp;
678     # Get a filehandle/name to write it to
679     my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
681     # Loop over file data writing out to temporary file.
682     while ( $bytesleft )
683     {
684         $blocksize = $bytesleft if ( $bytesleft < $blocksize );
685         read STDIN, $tmp, $blocksize;
686         print $fh $tmp;
687         $bytesleft -= $blocksize;
688     }
690     close $fh
691         or (print "E failed to write temporary, $filename: $!\n"), return;
693     # Ensure we have something sensible for the file mode
694     if ( $mode =~ /u=(\w+)/ )
695     {
696         $mode = $1;
697     } else {
698         $mode = "rw";
699     }
701     # Save the file data in $state
702     $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
703     $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
704     $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
705     $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
707     #$log->debug("req_Modified : file=$data mode=$mode size=$size");
710 # Unchanged filename \n
711 #     Response expected: no. Tell the server that filename has not been
712 #     modified in the checked out directory. The filename is a file within the
713 #     most recent directory sent with Directory; it must not contain `/'.
714 sub req_Unchanged
716     my ( $cmd, $data ) = @_;
718     $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
720     #$log->debug("req_Unchanged : $data");
723 # Argument text \n
724 #     Response expected: no. Save argument for use in a subsequent command.
725 #     Arguments accumulate until an argument-using command is given, at which
726 #     point they are forgotten.
727 # Argumentx text \n
728 #     Response expected: no. Append \n followed by text to the current argument
729 #     being saved.
730 sub req_Argument
732     my ( $cmd, $data ) = @_;
734     # Argumentx means: append to last Argument (with a newline in front)
736     $log->debug("$cmd : $data");
738     if ( $cmd eq 'Argumentx') {
739         ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
740     } else {
741         push @{$state->{arguments}}, $data;
742     }
745 # expand-modules \n
746 #     Response expected: yes. Expand the modules which are specified in the
747 #     arguments. Returns the data in Module-expansion responses. Note that the
748 #     server can assume that this is checkout or export, not rtag or rdiff; the
749 #     latter do not access the working directory and thus have no need to
750 #     expand modules on the client side. Expand may not be the best word for
751 #     what this request does. It does not necessarily tell you all the files
752 #     contained in a module, for example. Basically it is a way of telling you
753 #     which working directories the server needs to know about in order to
754 #     handle a checkout of the specified modules. For example, suppose that the
755 #     server has a module defined by
756 #   aliasmodule -a 1dir
757 #     That is, one can check out aliasmodule and it will take 1dir in the
758 #     repository and check it out to 1dir in the working directory. Now suppose
759 #     the client already has this module checked out and is planning on using
760 #     the co request to update it. Without using expand-modules, the client
761 #     would have two bad choices: it could either send information about all
762 #     working directories under the current directory, which could be
763 #     unnecessarily slow, or it could be ignorant of the fact that aliasmodule
764 #     stands for 1dir, and neglect to send information for 1dir, which would
765 #     lead to incorrect operation. With expand-modules, the client would first
766 #     ask for the module to be expanded:
767 sub req_expandmodules
769     my ( $cmd, $data ) = @_;
771     argsplit();
773     $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
775     unless ( ref $state->{arguments} eq "ARRAY" )
776     {
777         print "ok\n";
778         return;
779     }
781     foreach my $module ( @{$state->{arguments}} )
782     {
783         $log->debug("SEND : Module-expansion $module");
784         print "Module-expansion $module\n";
785     }
787     print "ok\n";
788     statecleanup();
791 # co \n
792 #     Response expected: yes. Get files from the repository. This uses any
793 #     previous Argument, Directory, Entry, or Modified requests, if they have
794 #     been sent. Arguments to this command are module names; the client cannot
795 #     know what directories they correspond to except by (1) just sending the
796 #     co request, and then seeing what directory names the server sends back in
797 #     its responses, and (2) the expand-modules request.
798 sub req_co
800     my ( $cmd, $data ) = @_;
802     argsplit("co");
804     my $module = $state->{args}[0];
805     $state->{module} = $module;
806     my $checkout_path = $module;
808     # use the user specified directory if we're given it
809     $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
811     $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
813     $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
815     $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
817     # Grab a handle to the SQLite db and do any necessary updates
818     my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
819     $updater->update();
821     $checkout_path =~ s|/$||; # get rid of trailing slashes
823     # Eclipse seems to need the Clear-sticky command
824     # to prepare the 'Entries' file for the new directory.
825     print "Clear-sticky $checkout_path/\n";
826     print $state->{CVSROOT} . "/$module/\n";
827     print "Clear-static-directory $checkout_path/\n";
828     print $state->{CVSROOT} . "/$module/\n";
829     print "Clear-sticky $checkout_path/\n"; # yes, twice
830     print $state->{CVSROOT} . "/$module/\n";
831     print "Template $checkout_path/\n";
832     print $state->{CVSROOT} . "/$module/\n";
833     print "0\n";
835     # instruct the client that we're checking out to $checkout_path
836     print "E cvs checkout: Updating $checkout_path\n";
838     my %seendirs = ();
839     my $lastdir ='';
841     # recursive
842     sub prepdir {
843        my ($dir, $repodir, $remotedir, $seendirs) = @_;
844        my $parent = dirname($dir);
845        $dir       =~ s|/+$||;
846        $repodir   =~ s|/+$||;
847        $remotedir =~ s|/+$||;
848        $parent    =~ s|/+$||;
849        $log->debug("announcedir $dir, $repodir, $remotedir" );
851        if ($parent eq '.' || $parent eq './') {
852            $parent = '';
853        }
854        # recurse to announce unseen parents first
855        if (length($parent) && !exists($seendirs->{$parent})) {
856            prepdir($parent, $repodir, $remotedir, $seendirs);
857        }
858        # Announce that we are going to modify at the parent level
859        if ($parent) {
860            print "E cvs checkout: Updating $remotedir/$parent\n";
861        } else {
862            print "E cvs checkout: Updating $remotedir\n";
863        }
864        print "Clear-sticky $remotedir/$parent/\n";
865        print "$repodir/$parent/\n";
867        print "Clear-static-directory $remotedir/$dir/\n";
868        print "$repodir/$dir/\n";
869        print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
870        print "$repodir/$parent/\n";
871        print "Template $remotedir/$dir/\n";
872        print "$repodir/$dir/\n";
873        print "0\n";
875        $seendirs->{$dir} = 1;
876     }
878     foreach my $git ( @{$updater->gethead} )
879     {
880         # Don't want to check out deleted files
881         next if ( $git->{filehash} eq "deleted" );
883         my $fullName = $git->{name};
884         ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
886        if (length($git->{dir}) && $git->{dir} ne './'
887            && $git->{dir} ne $lastdir ) {
888            unless (exists($seendirs{$git->{dir}})) {
889                prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
890                        $checkout_path, \%seendirs);
891                $lastdir = $git->{dir};
892                $seendirs{$git->{dir}} = 1;
893            }
894            print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
895        }
897         # modification time of this file
898         print "Mod-time $git->{modified}\n";
900         # print some information to the client
901         if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
902         {
903             print "M U $checkout_path/$git->{dir}$git->{name}\n";
904         } else {
905             print "M U $checkout_path/$git->{name}\n";
906         }
908        # instruct client we're sending a file to put in this path
909        print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
911        print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
913         # this is an "entries" line
914         my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
915         print "/$git->{name}/1.$git->{revision}//$kopts/\n";
916         # permissions
917         print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
919         # transmit file
920         transmitfile($git->{filehash});
921     }
923     print "ok\n";
925     statecleanup();
928 # update \n
929 #     Response expected: yes. Actually do a cvs update command. This uses any
930 #     previous Argument, Directory, Entry, or Modified requests, if they have
931 #     been sent. The last Directory sent specifies the working directory at the
932 #     time of the operation. The -I option is not used--files which the client
933 #     can decide whether to ignore are not mentioned and the client sends the
934 #     Questionable request for others.
935 sub req_update
937     my ( $cmd, $data ) = @_;
939     $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
941     argsplit("update");
943     #
944     # It may just be a client exploring the available heads/modules
945     # in that case, list them as top level directories and leave it
946     # at that. Eclipse uses this technique to offer you a list of
947     # projects (heads in this case) to checkout.
948     #
949     if ($state->{module} eq '') {
950         my $heads_dir = $state->{CVSROOT} . '/refs/heads';
951         if (!opendir HEADS, $heads_dir) {
952             print "E [server aborted]: Failed to open directory, "
953               . "$heads_dir: $!\nerror\n";
954             return 0;
955         }
956         print "E cvs update: Updating .\n";
957         while (my $head = readdir(HEADS)) {
958             if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
959                 print "E cvs update: New directory `$head'\n";
960             }
961         }
962         closedir HEADS;
963         print "ok\n";
964         return 1;
965     }
968     # Grab a handle to the SQLite db and do any necessary updates
969     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
971     $updater->update();
973     argsfromdir($updater);
975     #$log->debug("update state : " . Dumper($state));
977     # foreach file specified on the command line ...
978     foreach my $filename ( @{$state->{args}} )
979     {
980         $filename = filecleanup($filename);
982         $log->debug("Processing file $filename");
984         # if we have a -C we should pretend we never saw modified stuff
985         if ( exists ( $state->{opt}{C} ) )
986         {
987             delete $state->{entries}{$filename}{modified_hash};
988             delete $state->{entries}{$filename}{modified_filename};
989             $state->{entries}{$filename}{unchanged} = 1;
990         }
992         my $meta;
993         if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
994         {
995             $meta = $updater->getmeta($filename, $1);
996         } else {
997             $meta = $updater->getmeta($filename);
998         }
1000         # If -p was given, "print" the contents of the requested revision.
1001         if ( exists ( $state->{opt}{p} ) ) {
1002             if ( defined ( $meta->{revision} ) ) {
1003                 $log->info("Printing '$filename' revision " . $meta->{revision});
1005                 transmitfile($meta->{filehash}, { print => 1 });
1006             }
1008             next;
1009         }
1011         if ( ! defined $meta )
1012         {
1013             $meta = {
1014                 name => $filename,
1015                 revision => 0,
1016                 filehash => 'added'
1017             };
1018         }
1020         my $oldmeta = $meta;
1022         my $wrev = revparse($filename);
1024         # If the working copy is an old revision, lets get that version too for comparison.
1025         if ( defined($wrev) and $wrev != $meta->{revision} )
1026         {
1027             $oldmeta = $updater->getmeta($filename, $wrev);
1028         }
1030         #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1032         # Files are up to date if the working copy and repo copy have the same revision,
1033         # and the working copy is unmodified _and_ the user hasn't specified -C
1034         next if ( defined ( $wrev )
1035                   and defined($meta->{revision})
1036                   and $wrev == $meta->{revision}
1037                   and $state->{entries}{$filename}{unchanged}
1038                   and not exists ( $state->{opt}{C} ) );
1040         # If the working copy and repo copy have the same revision,
1041         # but the working copy is modified, tell the client it's modified
1042         if ( defined ( $wrev )
1043              and defined($meta->{revision})
1044              and $wrev == $meta->{revision}
1045              and defined($state->{entries}{$filename}{modified_hash})
1046              and not exists ( $state->{opt}{C} ) )
1047         {
1048             $log->info("Tell the client the file is modified");
1049             print "MT text M \n";
1050             print "MT fname $filename\n";
1051             print "MT newline\n";
1052             next;
1053         }
1055         if ( $meta->{filehash} eq "deleted" )
1056         {
1057             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1059             $log->info("Removing '$filename' from working copy (no longer in the repo)");
1061             print "E cvs update: `$filename' is no longer in the repository\n";
1062             # Don't want to actually _DO_ the update if -n specified
1063             unless ( $state->{globaloptions}{-n} ) {
1064                 print "Removed $dirpart\n";
1065                 print "$filepart\n";
1066             }
1067         }
1068         elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
1069                 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1070                 or $meta->{filehash} eq 'added' )
1071         {
1072             # normal update, just send the new revision (either U=Update,
1073             # or A=Add, or R=Remove)
1074             if ( defined($wrev) && $wrev < 0 )
1075             {
1076                 $log->info("Tell the client the file is scheduled for removal");
1077                 print "MT text R \n";
1078                 print "MT fname $filename\n";
1079                 print "MT newline\n";
1080                 next;
1081             }
1082             elsif ( (!defined($wrev) || $wrev == 0) && (!defined($meta->{revision}) || $meta->{revision} == 0) )
1083             {
1084                 $log->info("Tell the client the file is scheduled for addition");
1085                 print "MT text A \n";
1086                 print "MT fname $filename\n";
1087                 print "MT newline\n";
1088                 next;
1090             }
1091             else {
1092                 $log->info("Updating '$filename' to ".$meta->{revision});
1093                 print "MT +updated\n";
1094                 print "MT text U \n";
1095                 print "MT fname $filename\n";
1096                 print "MT newline\n";
1097                 print "MT -updated\n";
1098             }
1100             my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1102             # Don't want to actually _DO_ the update if -n specified
1103             unless ( $state->{globaloptions}{-n} )
1104             {
1105                 if ( defined ( $wrev ) )
1106                 {
1107                     # instruct client we're sending a file to put in this path as a replacement
1108                     print "Update-existing $dirpart\n";
1109                     $log->debug("Updating existing file 'Update-existing $dirpart'");
1110                 } else {
1111                     # instruct client we're sending a file to put in this path as a new file
1112                     print "Clear-static-directory $dirpart\n";
1113                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1114                     print "Clear-sticky $dirpart\n";
1115                     print $state->{CVSROOT} . "/$state->{module}/$dirpart\n";
1117                     $log->debug("Creating new file 'Created $dirpart'");
1118                     print "Created $dirpart\n";
1119                 }
1120                 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1122                 # this is an "entries" line
1123                 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1124                 $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1125                 print "/$filepart/1.$meta->{revision}//$kopts/\n";
1127                 # permissions
1128                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1129                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1131                 # transmit file
1132                 transmitfile($meta->{filehash});
1133             }
1134         } else {
1135             $log->info("Updating '$filename'");
1136             my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
1138             my $mergeDir = setupTmpDir();
1140             my $file_local = $filepart . ".mine";
1141             my $mergedFile = "$mergeDir/$file_local";
1142             system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1143             my $file_old = $filepart . "." . $oldmeta->{revision};
1144             transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
1145             my $file_new = $filepart . "." . $meta->{revision};
1146             transmitfile($meta->{filehash}, { targetfile => $file_new });
1148             # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1149             $log->info("Merging $file_local, $file_old, $file_new");
1150             print "M Merging differences between 1.$oldmeta->{revision} and 1.$meta->{revision} into $filename\n";
1152             $log->debug("Temporary directory for merge is $mergeDir");
1154             my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1155             $return >>= 8;
1157             cleanupTmpDir();
1159             if ( $return == 0 )
1160             {
1161                 $log->info("Merged successfully");
1162                 print "M M $filename\n";
1163                 $log->debug("Merged $dirpart");
1165                 # Don't want to actually _DO_ the update if -n specified
1166                 unless ( $state->{globaloptions}{-n} )
1167                 {
1168                     print "Merged $dirpart\n";
1169                     $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1170                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1171                     my $kopts = kopts_from_path("$dirpart/$filepart",
1172                                                 "file",$mergedFile);
1173                     $log->debug("/$filepart/1.$meta->{revision}//$kopts/");
1174                     print "/$filepart/1.$meta->{revision}//$kopts/\n";
1175                 }
1176             }
1177             elsif ( $return == 1 )
1178             {
1179                 $log->info("Merged with conflicts");
1180                 print "E cvs update: conflicts found in $filename\n";
1181                 print "M C $filename\n";
1183                 # Don't want to actually _DO_ the update if -n specified
1184                 unless ( $state->{globaloptions}{-n} )
1185                 {
1186                     print "Merged $dirpart\n";
1187                     print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1188                     my $kopts = kopts_from_path("$dirpart/$filepart",
1189                                                 "file",$mergedFile);
1190                     print "/$filepart/1.$meta->{revision}/+/$kopts/\n";
1191                 }
1192             }
1193             else
1194             {
1195                 $log->warn("Merge failed");
1196                 next;
1197             }
1199             # Don't want to actually _DO_ the update if -n specified
1200             unless ( $state->{globaloptions}{-n} )
1201             {
1202                 # permissions
1203                 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1204                 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1206                 # transmit file, format is single integer on a line by itself (file
1207                 # size) followed by the file contents
1208                 # TODO : we should copy files in blocks
1209                 my $data = `cat $mergedFile`;
1210                 $log->debug("File size : " . length($data));
1211                 print length($data) . "\n";
1212                 print $data;
1213             }
1214         }
1216     }
1218     print "ok\n";
1221 sub req_ci
1223     my ( $cmd, $data ) = @_;
1225     argsplit("ci");
1227     #$log->debug("State : " . Dumper($state));
1229     $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1231     if ( $state->{method} eq 'pserver')
1232     {
1233         print "error 1 pserver access cannot commit\n";
1234         cleanupWorkTree();
1235         exit;
1236     }
1238     if ( -e $state->{CVSROOT} . "/index" )
1239     {
1240         $log->warn("file 'index' already exists in the git repository");
1241         print "error 1 Index already exists in git repo\n";
1242         cleanupWorkTree();
1243         exit;
1244     }
1246     # Grab a handle to the SQLite db and do any necessary updates
1247     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1248     $updater->update();
1250     # Remember where the head was at the beginning.
1251     my $parenthash = `git show-ref -s refs/heads/$state->{module}`;
1252     chomp $parenthash;
1253     if ($parenthash !~ /^[0-9a-f]{40}$/) {
1254             print "error 1 pserver cannot find the current HEAD of module";
1255             cleanupWorkTree();
1256             exit;
1257     }
1259     setupWorkTree($parenthash);
1261     $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1263     $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1265     my @committedfiles = ();
1266     my %oldmeta;
1268     # foreach file specified on the command line ...
1269     foreach my $filename ( @{$state->{args}} )
1270     {
1271         my $committedfile = $filename;
1272         $filename = filecleanup($filename);
1274         next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1276         my $meta = $updater->getmeta($filename);
1277         $oldmeta{$filename} = $meta;
1279         my $wrev = revparse($filename);
1281         my ( $filepart, $dirpart ) = filenamesplit($filename);
1283         # do a checkout of the file if it is part of this tree
1284         if ($wrev) {
1285             system('git-checkout-index', '-f', '-u', $filename);
1286             unless ($? == 0) {
1287                 die "Error running git-checkout-index -f -u $filename : $!";
1288             }
1289         }
1291         my $addflag = 0;
1292         my $rmflag = 0;
1293         $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
1294         $addflag = 1 unless ( -e $filename );
1296         # Do up to date checking
1297         unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
1298         {
1299             # fail everything if an up to date check fails
1300             print "error 1 Up to date check failed for $filename\n";
1301             cleanupWorkTree();
1302             exit;
1303         }
1305         push @committedfiles, $committedfile;
1306         $log->info("Committing $filename");
1308         system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1310         unless ( $rmflag )
1311         {
1312             $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1313             rename $state->{entries}{$filename}{modified_filename},$filename;
1315             # Calculate modes to remove
1316             my $invmode = "";
1317             foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1319             $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1320             system("chmod","u+" .  $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1321         }
1323         if ( $rmflag )
1324         {
1325             $log->info("Removing file '$filename'");
1326             unlink($filename);
1327             system("git-update-index", "--remove", $filename);
1328         }
1329         elsif ( $addflag )
1330         {
1331             $log->info("Adding file '$filename'");
1332             system("git-update-index", "--add", $filename);
1333         } else {
1334             $log->info("Updating file '$filename'");
1335             system("git-update-index", $filename);
1336         }
1337     }
1339     unless ( scalar(@committedfiles) > 0 )
1340     {
1341         print "E No files to commit\n";
1342         print "ok\n";
1343         cleanupWorkTree();
1344         return;
1345     }
1347     my $treehash = `git-write-tree`;
1348     chomp $treehash;
1350     $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1352     # write our commit message out if we have one ...
1353     my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1354     print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1355     print $msg_fh "\n\nvia git-CVS emulator\n";
1356     close $msg_fh;
1358     my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1359     chomp($commithash);
1360     $log->info("Commit hash : $commithash");
1362     unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1363     {
1364         $log->warn("Commit failed (Invalid commit hash)");
1365         print "error 1 Commit failed (unknown reason)\n";
1366         cleanupWorkTree();
1367         exit;
1368     }
1370         ### Emulate git-receive-pack by running hooks/update
1371         my @hook = ( $ENV{GIT_DIR}.'hooks/update', "refs/heads/$state->{module}",
1372                         $parenthash, $commithash );
1373         if( -x $hook[0] ) {
1374                 unless( system( @hook ) == 0 )
1375                 {
1376                         $log->warn("Commit failed (update hook declined to update ref)");
1377                         print "error 1 Commit failed (update hook declined)\n";
1378                         cleanupWorkTree();
1379                         exit;
1380                 }
1381         }
1383         ### Update the ref
1384         if (system(qw(git update-ref -m), "cvsserver ci",
1385                         "refs/heads/$state->{module}", $commithash, $parenthash)) {
1386                 $log->warn("update-ref for $state->{module} failed.");
1387                 print "error 1 Cannot commit -- update first\n";
1388                 cleanupWorkTree();
1389                 exit;
1390         }
1392         ### Emulate git-receive-pack by running hooks/post-receive
1393         my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1394         if( -x $hook ) {
1395                 open(my $pipe, "| $hook") || die "can't fork $!";
1397                 local $SIG{PIPE} = sub { die 'pipe broke' };
1399                 print $pipe "$parenthash $commithash refs/heads/$state->{module}\n";
1401                 close $pipe || die "bad pipe: $! $?";
1402         }
1404         ### Then hooks/post-update
1405         $hook = $ENV{GIT_DIR}.'hooks/post-update';
1406         if (-x $hook) {
1407                 system($hook, "refs/heads/$state->{module}");
1408         }
1410     $updater->update();
1412     # foreach file specified on the command line ...
1413     foreach my $filename ( @committedfiles )
1414     {
1415         $filename = filecleanup($filename);
1417         my $meta = $updater->getmeta($filename);
1418         unless (defined $meta->{revision}) {
1419           $meta->{revision} = 1;
1420         }
1422         my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
1424         $log->debug("Checked-in $dirpart : $filename");
1426         print "M $state->{CVSROOT}/$state->{module}/$filename,v  <--  $dirpart$filepart\n";
1427         if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
1428         {
1429             print "M new revision: delete; previous revision: 1.$oldmeta{$filename}{revision}\n";
1430             print "Remove-entry $dirpart\n";
1431             print "$filename\n";
1432         } else {
1433             if ($meta->{revision} == 1) {
1434                 print "M initial revision: 1.1\n";
1435             } else {
1436                 print "M new revision: 1.$meta->{revision}; previous revision: 1.$oldmeta{$filename}{revision}\n";
1437             }
1438             print "Checked-in $dirpart\n";
1439             print "$filename\n";
1440             my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
1441             print "/$filepart/1.$meta->{revision}//$kopts/\n";
1442         }
1443     }
1445     cleanupWorkTree();
1446     print "ok\n";
1449 sub req_status
1451     my ( $cmd, $data ) = @_;
1453     argsplit("status");
1455     $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1456     #$log->debug("status state : " . Dumper($state));
1458     # Grab a handle to the SQLite db and do any necessary updates
1459     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1460     $updater->update();
1462     # if no files were specified, we need to work out what files we should be providing status on ...
1463     argsfromdir($updater);
1465     # foreach file specified on the command line ...
1466     foreach my $filename ( @{$state->{args}} )
1467     {
1468         $filename = filecleanup($filename);
1470         next if exists($state->{opt}{l}) && index($filename, '/', length($state->{prependdir})) >= 0;
1472         my $meta = $updater->getmeta($filename);
1473         my $oldmeta = $meta;
1475         my $wrev = revparse($filename);
1477         # If the working copy is an old revision, lets get that version too for comparison.
1478         if ( defined($wrev) and $wrev != $meta->{revision} )
1479         {
1480             $oldmeta = $updater->getmeta($filename, $wrev);
1481         }
1483         # TODO : All possible statuses aren't yet implemented
1484         my $status;
1485         # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1486         $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1487                                     and
1488                                     ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1489                                       or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1490                                    );
1492         # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1493         $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1494                                           and
1495                                           ( $state->{entries}{$filename}{unchanged}
1496                                             or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1497                                         );
1499         # Need checkout if it exists in the repo but doesn't have a working copy
1500         $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1502         # Locally modified if working copy and repo copy have the same revision but there are local changes
1503         $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1505         # Needs Merge if working copy revision is less than repo copy and there are local changes
1506         $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1508         $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1509         $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1510         $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1511         $status ||= "File had conflicts on merge" if ( 0 );
1513         $status ||= "Unknown";
1515         my ($filepart) = filenamesplit($filename);
1517         print "M ===================================================================\n";
1518         print "M File: $filepart\tStatus: $status\n";
1519         if ( defined($state->{entries}{$filename}{revision}) )
1520         {
1521             print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1522         } else {
1523             print "M Working revision:\tNo entry for $filename\n";
1524         }
1525         if ( defined($meta->{revision}) )
1526         {
1527             print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1528             print "M Sticky Tag:\t\t(none)\n";
1529             print "M Sticky Date:\t\t(none)\n";
1530             print "M Sticky Options:\t\t(none)\n";
1531         } else {
1532             print "M Repository revision:\tNo revision control file\n";
1533         }
1534         print "M\n";
1535     }
1537     print "ok\n";
1540 sub req_diff
1542     my ( $cmd, $data ) = @_;
1544     argsplit("diff");
1546     $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1547     #$log->debug("status state : " . Dumper($state));
1549     my ($revision1, $revision2);
1550     if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1551     {
1552         $revision1 = $state->{opt}{r}[0];
1553         $revision2 = $state->{opt}{r}[1];
1554     } else {
1555         $revision1 = $state->{opt}{r};
1556     }
1558     $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1559     $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1561     $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1563     # Grab a handle to the SQLite db and do any necessary updates
1564     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1565     $updater->update();
1567     # if no files were specified, we need to work out what files we should be providing status on ...
1568     argsfromdir($updater);
1570     # foreach file specified on the command line ...
1571     foreach my $filename ( @{$state->{args}} )
1572     {
1573         $filename = filecleanup($filename);
1575         my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1577         my $wrev = revparse($filename);
1579         # We need _something_ to diff against
1580         next unless ( defined ( $wrev ) );
1582         # if we have a -r switch, use it
1583         if ( defined ( $revision1 ) )
1584         {
1585             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1586             $meta1 = $updater->getmeta($filename, $revision1);
1587             unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1588             {
1589                 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1590                 next;
1591             }
1592             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1593         }
1594         # otherwise we just use the working copy revision
1595         else
1596         {
1597             ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1598             $meta1 = $updater->getmeta($filename, $wrev);
1599             transmitfile($meta1->{filehash}, { targetfile => $file1 });
1600         }
1602         # if we have a second -r switch, use it too
1603         if ( defined ( $revision2 ) )
1604         {
1605             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1606             $meta2 = $updater->getmeta($filename, $revision2);
1608             unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1609             {
1610                 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1611                 next;
1612             }
1614             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1615         }
1616         # otherwise we just use the working copy
1617         else
1618         {
1619             $file2 = $state->{entries}{$filename}{modified_filename};
1620         }
1622         # if we have been given -r, and we don't have a $file2 yet, lets get one
1623         if ( defined ( $revision1 ) and not defined ( $file2 ) )
1624         {
1625             ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1626             $meta2 = $updater->getmeta($filename, $wrev);
1627             transmitfile($meta2->{filehash}, { targetfile => $file2 });
1628         }
1630         # We need to have retrieved something useful
1631         next unless ( defined ( $meta1 ) );
1633         # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1634         next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1635                   and
1636                    ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1637                      or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1638                   );
1640         # Apparently we only show diffs for locally modified files
1641         next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1643         print "M Index: $filename\n";
1644         print "M ===================================================================\n";
1645         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1646         print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1647         print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1648         print "M diff ";
1649         foreach my $opt ( keys %{$state->{opt}} )
1650         {
1651             if ( ref $state->{opt}{$opt} eq "ARRAY" )
1652             {
1653                 foreach my $value ( @{$state->{opt}{$opt}} )
1654                 {
1655                     print "-$opt $value ";
1656                 }
1657             } else {
1658                 print "-$opt ";
1659                 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1660             }
1661         }
1662         print "$filename\n";
1664         $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1666         ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1668         if ( exists $state->{opt}{u} )
1669         {
1670             system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1671         } else {
1672             system("diff $file1 $file2 > $filediff");
1673         }
1675         while ( <$fh> )
1676         {
1677             print "M $_";
1678         }
1679         close $fh;
1680     }
1682     print "ok\n";
1685 sub req_log
1687     my ( $cmd, $data ) = @_;
1689     argsplit("log");
1691     $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1692     #$log->debug("log state : " . Dumper($state));
1694     my ( $minrev, $maxrev );
1695     if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1696     {
1697         my $control = $2;
1698         $minrev = $1;
1699         $maxrev = $3;
1700         $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1701         $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1702         $minrev++ if ( defined($minrev) and $control eq "::" );
1703     }
1705     # Grab a handle to the SQLite db and do any necessary updates
1706     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1707     $updater->update();
1709     # if no files were specified, we need to work out what files we should be providing status on ...
1710     argsfromdir($updater);
1712     # foreach file specified on the command line ...
1713     foreach my $filename ( @{$state->{args}} )
1714     {
1715         $filename = filecleanup($filename);
1717         my $headmeta = $updater->getmeta($filename);
1719         my $revisions = $updater->getlog($filename);
1720         my $totalrevisions = scalar(@$revisions);
1722         if ( defined ( $minrev ) )
1723         {
1724             $log->debug("Removing revisions less than $minrev");
1725             while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1726             {
1727                 pop @$revisions;
1728             }
1729         }
1730         if ( defined ( $maxrev ) )
1731         {
1732             $log->debug("Removing revisions greater than $maxrev");
1733             while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1734             {
1735                 shift @$revisions;
1736             }
1737         }
1739         next unless ( scalar(@$revisions) );
1741         print "M \n";
1742         print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1743         print "M Working file: $filename\n";
1744         print "M head: 1.$headmeta->{revision}\n";
1745         print "M branch:\n";
1746         print "M locks: strict\n";
1747         print "M access list:\n";
1748         print "M symbolic names:\n";
1749         print "M keyword substitution: kv\n";
1750         print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1751         print "M description:\n";
1753         foreach my $revision ( @$revisions )
1754         {
1755             print "M ----------------------------\n";
1756             print "M revision 1.$revision->{revision}\n";
1757             # reformat the date for log output
1758             $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}) );
1759             $revision->{author} = cvs_author($revision->{author});
1760             print "M date: $revision->{modified};  author: $revision->{author};  state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . ";  lines: +2 -3\n";
1761             my $commitmessage = $updater->commitmessage($revision->{commithash});
1762             $commitmessage =~ s/^/M /mg;
1763             print $commitmessage . "\n";
1764         }
1765         print "M =============================================================================\n";
1766     }
1768     print "ok\n";
1771 sub req_annotate
1773     my ( $cmd, $data ) = @_;
1775     argsplit("annotate");
1777     $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1778     #$log->debug("status state : " . Dumper($state));
1780     # Grab a handle to the SQLite db and do any necessary updates
1781     my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1782     $updater->update();
1784     # if no files were specified, we need to work out what files we should be providing annotate on ...
1785     argsfromdir($updater);
1787     # we'll need a temporary checkout dir
1788     setupWorkTree();
1790     $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
1792     # foreach file specified on the command line ...
1793     foreach my $filename ( @{$state->{args}} )
1794     {
1795         $filename = filecleanup($filename);
1797         my $meta = $updater->getmeta($filename);
1799         next unless ( $meta->{revision} );
1801         # get all the commits that this file was in
1802         # in dense format -- aka skip dead revisions
1803         my $revisions   = $updater->gethistorydense($filename);
1804         my $lastseenin  = $revisions->[0][2];
1806         # populate the temporary index based on the latest commit were we saw
1807         # the file -- but do it cheaply without checking out any files
1808         # TODO: if we got a revision from the client, use that instead
1809         # to look up the commithash in sqlite (still good to default to
1810         # the current head as we do now)
1811         system("git-read-tree", $lastseenin);
1812         unless ($? == 0)
1813         {
1814             print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
1815             return;
1816         }
1817         $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
1819         # do a checkout of the file
1820         system('git-checkout-index', '-f', '-u', $filename);
1821         unless ($? == 0) {
1822             print "E error running git-checkout-index -f -u $filename : $!\n";
1823             return;
1824         }
1826         $log->info("Annotate $filename");
1828         # Prepare a file with the commits from the linearized
1829         # history that annotate should know about. This prevents
1830         # git-jsannotate telling us about commits we are hiding
1831         # from the client.
1833         my $a_hints = "$work->{workDir}/.annotate_hints";
1834         if (!open(ANNOTATEHINTS, '>', $a_hints)) {
1835             print "E failed to open '$a_hints' for writing: $!\n";
1836             return;
1837         }
1838         for (my $i=0; $i < @$revisions; $i++)
1839         {
1840             print ANNOTATEHINTS $revisions->[$i][2];
1841             if ($i+1 < @$revisions) { # have we got a parent?
1842                 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1843             }
1844             print ANNOTATEHINTS "\n";
1845         }
1847         print ANNOTATEHINTS "\n";
1848         close ANNOTATEHINTS
1849             or (print "E failed to write $a_hints: $!\n"), return;
1851         my @cmd = (qw(git-annotate -l -S), $a_hints, $filename);
1852         if (!open(ANNOTATE, "-|", @cmd)) {
1853             print "E error invoking ". join(' ',@cmd) .": $!\n";
1854             return;
1855         }
1856         my $metadata = {};
1857         print "E Annotations for $filename\n";
1858         print "E ***************\n";
1859         while ( <ANNOTATE> )
1860         {
1861             if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1862             {
1863                 my $commithash = $1;
1864                 my $data = $2;
1865                 unless ( defined ( $metadata->{$commithash} ) )
1866                 {
1867                     $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1868                     $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
1869                     $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1870                 }
1871                 printf("M 1.%-5d      (%-8s %10s): %s\n",
1872                     $metadata->{$commithash}{revision},
1873                     $metadata->{$commithash}{author},
1874                     $metadata->{$commithash}{modified},
1875                     $data
1876                 );
1877             } else {
1878                 $log->warn("Error in annotate output! LINE: $_");
1879                 print "E Annotate error \n";
1880                 next;
1881             }
1882         }
1883         close ANNOTATE;
1884     }
1886     # done; get out of the tempdir
1887     cleanupWorkDir();
1889     print "ok\n";
1893 # This method takes the state->{arguments} array and produces two new arrays.
1894 # The first is $state->{args} which is everything before the '--' argument, and
1895 # the second is $state->{files} which is everything after it.
1896 sub argsplit
1898     $state->{args} = [];
1899     $state->{files} = [];
1900     $state->{opt} = {};
1902     return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1904     my $type = shift;
1906     if ( defined($type) )
1907     {
1908         my $opt = {};
1909         $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" );
1910         $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1911         $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" );
1912         $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1913         $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1914         $opt = { k => 1, m => 1 } if ( $type eq "add" );
1915         $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1916         $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" );
1919         while ( scalar ( @{$state->{arguments}} ) > 0 )
1920         {
1921             my $arg = shift @{$state->{arguments}};
1923             next if ( $arg eq "--" );
1924             next unless ( $arg =~ /\S/ );
1926             # if the argument looks like a switch
1927             if ( $arg =~ /^-(\w)(.*)/ )
1928             {
1929                 # if it's a switch that takes an argument
1930                 if ( $opt->{$1} )
1931                 {
1932                     # If this switch has already been provided
1933                     if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1934                     {
1935                         $state->{opt}{$1} = [ $state->{opt}{$1} ];
1936                         if ( length($2) > 0 )
1937                         {
1938                             push @{$state->{opt}{$1}},$2;
1939                         } else {
1940                             push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1941                         }
1942                     } else {
1943                         # if there's extra data in the arg, use that as the argument for the switch
1944                         if ( length($2) > 0 )
1945                         {
1946                             $state->{opt}{$1} = $2;
1947                         } else {
1948                             $state->{opt}{$1} = shift @{$state->{arguments}};
1949                         }
1950                     }
1951                 } else {
1952                     $state->{opt}{$1} = undef;
1953                 }
1954             }
1955             else
1956             {
1957                 push @{$state->{args}}, $arg;
1958             }
1959         }
1960     }
1961     else
1962     {
1963         my $mode = 0;
1965         foreach my $value ( @{$state->{arguments}} )
1966         {
1967             if ( $value eq "--" )
1968             {
1969                 $mode++;
1970                 next;
1971             }
1972             push @{$state->{args}}, $value if ( $mode == 0 );
1973             push @{$state->{files}}, $value if ( $mode == 1 );
1974         }
1975     }
1978 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1979 sub argsfromdir
1981     my $updater = shift;
1983     $state->{args} = [] if ( scalar(@{$state->{args}}) == 1 and $state->{args}[0] eq "." );
1985     return if ( scalar ( @{$state->{args}} ) > 1 );
1987     my @gethead = @{$updater->gethead};
1989     # push added files
1990     foreach my $file (keys %{$state->{entries}}) {
1991         if ( exists $state->{entries}{$file}{revision} &&
1992                 $state->{entries}{$file}{revision} == 0 )
1993         {
1994             push @gethead, { name => $file, filehash => 'added' };
1995         }
1996     }
1998     if ( scalar(@{$state->{args}}) == 1 )
1999     {
2000         my $arg = $state->{args}[0];
2001         $arg .= $state->{prependdir} if ( defined ( $state->{prependdir} ) );
2003         $log->info("Only one arg specified, checking for directory expansion on '$arg'");
2005         foreach my $file ( @gethead )
2006         {
2007             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2008             next unless ( $file->{name} =~ /^$arg\// or $file->{name} eq $arg  );
2009             push @{$state->{args}}, $file->{name};
2010         }
2012         shift @{$state->{args}} if ( scalar(@{$state->{args}}) > 1 );
2013     } else {
2014         $log->info("Only one arg specified, populating file list automatically");
2016         $state->{args} = [];
2018         foreach my $file ( @gethead )
2019         {
2020             next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
2021             next unless ( $file->{name} =~ s/^$state->{prependdir}// );
2022             push @{$state->{args}}, $file->{name};
2023         }
2024     }
2027 # This method cleans up the $state variable after a command that uses arguments has run
2028 sub statecleanup
2030     $state->{files} = [];
2031     $state->{args} = [];
2032     $state->{arguments} = [];
2033     $state->{entries} = {};
2036 sub revparse
2038     my $filename = shift;
2040     return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
2042     return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
2043     return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
2045     return undef;
2048 # This method takes a file hash and does a CVS "file transfer".  Its
2049 # exact behaviour depends on a second, optional hash table argument:
2050 # - If $options->{targetfile}, dump the contents to that file;
2051 # - If $options->{print}, use M/MT to transmit the contents one line
2052 #   at a time;
2053 # - Otherwise, transmit the size of the file, followed by the file
2054 #   contents.
2055 sub transmitfile
2057     my $filehash = shift;
2058     my $options = shift;
2060     if ( defined ( $filehash ) and $filehash eq "deleted" )
2061     {
2062         $log->warn("filehash is 'deleted'");
2063         return;
2064     }
2066     die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2068     my $type = `git-cat-file -t $filehash`;
2069     chomp $type;
2071     die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2073     my $size = `git-cat-file -s $filehash`;
2074     chomp $size;
2076     $log->debug("transmitfile($filehash) size=$size, type=$type");
2078     if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
2079     {
2080         if ( defined ( $options->{targetfile} ) )
2081         {
2082             my $targetfile = $options->{targetfile};
2083             open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2084             print NEWFILE $_ while ( <$fh> );
2085             close NEWFILE or die("Failed to write '$targetfile': $!");
2086         } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2087             while ( <$fh> ) {
2088                 if( /\n\z/ ) {
2089                     print 'M ', $_;
2090                 } else {
2091                     print 'MT text ', $_, "\n";
2092                 }
2093             }
2094         } else {
2095             print "$size\n";
2096             print while ( <$fh> );
2097         }
2098         close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2099     } else {
2100         die("Couldn't execute git-cat-file");
2101     }
2104 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2105 # refers to the directory portion and the file portion of the filename
2106 # respectively
2107 sub filenamesplit
2109     my $filename = shift;
2110     my $fixforlocaldir = shift;
2112     my ( $filepart, $dirpart ) = ( $filename, "." );
2113     ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2114     $dirpart .= "/";
2116     if ( $fixforlocaldir )
2117     {
2118         $dirpart =~ s/^$state->{prependdir}//;
2119     }
2121     return ( $filepart, $dirpart );
2124 sub filecleanup
2126     my $filename = shift;
2128     return undef unless(defined($filename));
2129     if ( $filename =~ /^\// )
2130     {
2131         print "E absolute filenames '$filename' not supported by server\n";
2132         return undef;
2133     }
2135     $filename =~ s/^\.\///g;
2136     $filename = $state->{prependdir} . $filename;
2137     return $filename;
2140 sub validateGitDir
2142     if( !defined($state->{CVSROOT}) )
2143     {
2144         print "error 1 CVSROOT not specified\n";
2145         cleanupWorkTree();
2146         exit;
2147     }
2148     if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2149     {
2150         print "error 1 Internally inconsistent CVSROOT\n";
2151         cleanupWorkTree();
2152         exit;
2153     }
2156 # Setup working directory in a work tree with the requested version
2157 # loaded in the index.
2158 sub setupWorkTree
2160     my ($ver) = @_;
2162     validateGitDir();
2164     if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2165         defined($work->{tmpDir}) )
2166     {
2167         $log->warn("Bad work tree state management");
2168         print "error 1 Internal setup multiple work trees without cleanup\n";
2169         cleanupWorkTree();
2170         exit;
2171     }
2173     $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2175     if( !defined($work->{index}) )
2176     {
2177         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2178     }
2180     chdir $work->{workDir} or
2181         die "Unable to chdir to $work->{workDir}\n";
2183     $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
2185     $ENV{GIT_WORK_TREE} = ".";
2186     $ENV{GIT_INDEX_FILE} = $work->{index};
2187     $work->{state} = 2;
2189     if($ver)
2190     {
2191         system("git","read-tree",$ver);
2192         unless ($? == 0)
2193         {
2194             $log->warn("Error running git-read-tree");
2195             die "Error running git-read-tree $ver in $work->{workDir} $!\n";
2196         }
2197     }
2198     # else # req_annotate reads tree for each file
2201 # Ensure current directory is in some kind of working directory,
2202 # with a recent version loaded in the index.
2203 sub ensureWorkTree
2205     if( defined($work->{tmpDir}) )
2206     {
2207         $log->warn("Bad work tree state management [ensureWorkTree()]");
2208         print "error 1 Internal setup multiple dirs without cleanup\n";
2209         cleanupWorkTree();
2210         exit;
2211     }
2212     if( $work->{state} )
2213     {
2214         return;
2215     }
2217     validateGitDir();
2219     if( !defined($work->{emptyDir}) )
2220     {
2221         $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
2222     }
2223     chdir $work->{emptyDir} or
2224         die "Unable to chdir to $work->{emptyDir}\n";
2226     my $ver = `git show-ref -s refs/heads/$state->{module}`;
2227     chomp $ver;
2228     if ($ver !~ /^[0-9a-f]{40}$/)
2229     {
2230         $log->warn("Error from git show-ref -s refs/head$state->{module}");
2231         print "error 1 cannot find the current HEAD of module";
2232         cleanupWorkTree();
2233         exit;
2234     }
2236     if( !defined($work->{index}) )
2237     {
2238         (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2239     }
2241     $ENV{GIT_WORK_TREE} = ".";
2242     $ENV{GIT_INDEX_FILE} = $work->{index};
2243     $work->{state} = 1;
2245     system("git","read-tree",$ver);
2246     unless ($? == 0)
2247     {
2248         die "Error running git-read-tree $ver $!\n";
2249     }
2252 # Cleanup working directory that is not needed any longer.
2253 sub cleanupWorkTree
2255     if( ! $work->{state} )
2256     {
2257         return;
2258     }
2260     chdir "/" or die "Unable to chdir '/'\n";
2262     if( defined($work->{workDir}) )
2263     {
2264         rmtree( $work->{workDir} );
2265         undef $work->{workDir};
2266     }
2267     undef $work->{state};
2270 # Setup a temporary directory (not a working tree), typically for
2271 # merging dirty state as in req_update.
2272 sub setupTmpDir
2274     $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
2275     chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
2277     return $work->{tmpDir};
2280 # Clean up a previously setupTmpDir.  Restore previous work tree if
2281 # appropriate.
2282 sub cleanupTmpDir
2284     if ( !defined($work->{tmpDir}) )
2285     {
2286         $log->warn("cleanup tmpdir that has not been setup");
2287         die "Cleanup tmpDir that has not been setup\n";
2288     }
2289     if( defined($work->{state}) )
2290     {
2291         if( $work->{state} == 1 )
2292         {
2293             chdir $work->{emptyDir} or
2294                 die "Unable to chdir to $work->{emptyDir}\n";
2295         }
2296         elsif( $work->{state} == 2 )
2297         {
2298             chdir $work->{workDir} or
2299                 die "Unable to chdir to $work->{emptyDir}\n";
2300         }
2301         else
2302         {
2303             $log->warn("Inconsistent work dir state");
2304             die "Inconsistent work dir state\n";
2305         }
2306     }
2307     else
2308     {
2309         chdir "/" or die "Unable to chdir '/'\n";
2310     }
2313 # Given a path, this function returns a string containing the kopts
2314 # that should go into that path's Entries line.  For example, a binary
2315 # file should get -kb.
2316 sub kopts_from_path
2318     my ($path, $srcType, $name) = @_;
2320     if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
2321          $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
2322     {
2323         my ($val) = check_attr( "crlf", $path );
2324         if ( $val eq "set" )
2325         {
2326             return "";
2327         }
2328         elsif ( $val eq "unset" )
2329         {
2330             return "-kb"
2331         }
2332         else
2333         {
2334             $log->info("Unrecognized check_attr crlf $path : $val");
2335         }
2336     }
2338     if ( defined ( $cfg->{gitcvs}{allbinary} ) )
2339     {
2340         if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
2341         {
2342             return "-kb";
2343         }
2344         elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
2345         {
2346             if( $srcType eq "sha1Or-k" &&
2347                 !defined($name) )
2348             {
2349                 my ($ret)=$state->{entries}{$path}{options};
2350                 if( !defined($ret) )
2351                 {
2352                     $ret=$state->{opt}{k};
2353                     if(defined($ret))
2354                     {
2355                         $ret="-k$ret";
2356                     }
2357                     else
2358                     {
2359                         $ret="";
2360                     }
2361                 }
2362                 if( ! ($ret=~/^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/) )
2363                 {
2364                     print "E Bad -k option\n";
2365                     $log->warn("Bad -k option: $ret");
2366                     die "Error: Bad -k option: $ret\n";
2367                 }
2369                 return $ret;
2370             }
2371             else
2372             {
2373                 if( is_binary($srcType,$name) )
2374                 {
2375                     $log->debug("... as binary");
2376                     return "-kb";
2377                 }
2378                 else
2379                 {
2380                     $log->debug("... as text");
2381                 }
2382             }
2383         }
2384     }
2385     # Return "" to give no special treatment to any path
2386     return "";
2389 sub check_attr
2391     my ($attr,$path) = @_;
2392     ensureWorkTree();
2393     if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
2394     {
2395         my $val = <$fh>;
2396         close $fh;
2397         $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
2398         return $val;
2399     }
2400     else
2401     {
2402         return undef;
2403     }
2406 # This should have the same heuristics as convert.c:is_binary() and related.
2407 # Note that the bare CR test is done by callers in convert.c.
2408 sub is_binary
2410     my ($srcType,$name) = @_;
2411     $log->debug("is_binary($srcType,$name)");
2413     # Minimize amount of interpreted code run in the inner per-character
2414     # loop for large files, by totalling each character value and
2415     # then analyzing the totals.
2416     my @counts;
2417     my $i;
2418     for($i=0;$i<256;$i++)
2419     {
2420         $counts[$i]=0;
2421     }
2423     my $fh = open_blob_or_die($srcType,$name);
2424     my $line;
2425     while( defined($line=<$fh>) )
2426     {
2427         # Any '\0' and bare CR are considered binary.
2428         if( $line =~ /\0|(\r[^\n])/ )
2429         {
2430             close($fh);
2431             return 1;
2432         }
2434         # Count up each character in the line:
2435         my $len=length($line);
2436         for($i=0;$i<$len;$i++)
2437         {
2438             $counts[ord(substr($line,$i,1))]++;
2439         }
2440     }
2441     close $fh;
2443     # Don't count CR and LF as either printable/nonprintable
2444     $counts[ord("\n")]=0;
2445     $counts[ord("\r")]=0;
2447     # Categorize individual character count into printable and nonprintable:
2448     my $printable=0;
2449     my $nonprintable=0;
2450     for($i=0;$i<256;$i++)
2451     {
2452         if( $i < 32 &&
2453             $i != ord("\b") &&
2454             $i != ord("\t") &&
2455             $i != 033 &&       # ESC
2456             $i != 014 )        # FF
2457         {
2458             $nonprintable+=$counts[$i];
2459         }
2460         elsif( $i==127 )  # DEL
2461         {
2462             $nonprintable+=$counts[$i];
2463         }
2464         else
2465         {
2466             $printable+=$counts[$i];
2467         }
2468     }
2470     return ($printable >> 7) < $nonprintable;
2473 # Returns open file handle.  Possible invocations:
2474 #  - open_blob_or_die("file",$filename);
2475 #  - open_blob_or_die("sha1",$filehash);
2476 sub open_blob_or_die
2478     my ($srcType,$name) = @_;
2479     my ($fh);
2480     if( $srcType eq "file" )
2481     {
2482         if( !open $fh,"<",$name )
2483         {
2484             $log->warn("Unable to open file $name: $!");
2485             die "Unable to open file $name: $!\n";
2486         }
2487     }
2488     elsif( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2489     {
2490         unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2491         {
2492             $log->warn("Need filehash");
2493             die "Need filehash\n";
2494         }
2496         my $type = `git cat-file -t $name`;
2497         chomp $type;
2499         unless ( defined ( $type ) and $type eq "blob" )
2500         {
2501             $log->warn("Invalid type '$type' for '$name'");
2502             die ( "Invalid type '$type' (expected 'blob')" )
2503         }
2505         my $size = `git cat-file -s $name`;
2506         chomp $size;
2508         $log->debug("open_blob_or_die($name) size=$size, type=$type");
2510         unless( open $fh, '-|', "git", "cat-file", "blob", $name )
2511         {
2512             $log->warn("Unable to open sha1 $name");
2513             die "Unable to open sha1 $name\n";
2514         }
2515     }
2516     else
2517     {
2518         $log->warn("Unknown type of blob source: $srcType");
2519         die "Unknown type of blob source: $srcType\n";
2520     }
2521     return $fh;
2524 # Generate a CVS author name from Git author information, by taking
2525 # the first eight characters of the user part of the email address.
2526 sub cvs_author
2528     my $author_line = shift;
2529     (my $author) = $author_line =~ /<([^>@]{1,8})/;
2531     $author;
2534 package GITCVS::log;
2536 ####
2537 #### Copyright The Open University UK - 2006.
2538 ####
2539 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2540 ####          Martin Langhoff <martin@catalyst.net.nz>
2541 ####
2542 ####
2544 use strict;
2545 use warnings;
2547 =head1 NAME
2549 GITCVS::log
2551 =head1 DESCRIPTION
2553 This module provides very crude logging with a similar interface to
2554 Log::Log4perl
2556 =head1 METHODS
2558 =cut
2560 =head2 new
2562 Creates a new log object, optionally you can specify a filename here to
2563 indicate the file to log to. If no log file is specified, you can specify one
2564 later with method setfile, or indicate you no longer want logging with method
2565 nofile.
2567 Until one of these methods is called, all log calls will buffer messages ready
2568 to write out.
2570 =cut
2571 sub new
2573     my $class = shift;
2574     my $filename = shift;
2576     my $self = {};
2578     bless $self, $class;
2580     if ( defined ( $filename ) )
2581     {
2582         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2583     }
2585     return $self;
2588 =head2 setfile
2590 This methods takes a filename, and attempts to open that file as the log file.
2591 If successful, all buffered data is written out to the file, and any further
2592 logging is written directly to the file.
2594 =cut
2595 sub setfile
2597     my $self = shift;
2598     my $filename = shift;
2600     if ( defined ( $filename ) )
2601     {
2602         open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
2603     }
2605     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2607     while ( my $line = shift @{$self->{buffer}} )
2608     {
2609         print {$self->{fh}} $line;
2610     }
2613 =head2 nofile
2615 This method indicates no logging is going to be used. It flushes any entries in
2616 the internal buffer, and sets a flag to ensure no further data is put there.
2618 =cut
2619 sub nofile
2621     my $self = shift;
2623     $self->{nolog} = 1;
2625     return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
2627     $self->{buffer} = [];
2630 =head2 _logopen
2632 Internal method. Returns true if the log file is open, false otherwise.
2634 =cut
2635 sub _logopen
2637     my $self = shift;
2639     return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
2640     return 0;
2643 =head2 debug info warn fatal
2645 These four methods are wrappers to _log. They provide the actual interface for
2646 logging data.
2648 =cut
2649 sub debug { my $self = shift; $self->_log("debug", @_); }
2650 sub info  { my $self = shift; $self->_log("info" , @_); }
2651 sub warn  { my $self = shift; $self->_log("warn" , @_); }
2652 sub fatal { my $self = shift; $self->_log("fatal", @_); }
2654 =head2 _log
2656 This is an internal method called by the logging functions. It generates a
2657 timestamp and pushes the logged line either to file, or internal buffer.
2659 =cut
2660 sub _log
2662     my $self = shift;
2663     my $level = shift;
2665     return if ( $self->{nolog} );
2667     my @time = localtime;
2668     my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
2669         $time[5] + 1900,
2670         $time[4] + 1,
2671         $time[3],
2672         $time[2],
2673         $time[1],
2674         $time[0],
2675         uc $level,
2676     );
2678     if ( $self->_logopen )
2679     {
2680         print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
2681     } else {
2682         push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
2683     }
2686 =head2 DESTROY
2688 This method simply closes the file handle if one is open
2690 =cut
2691 sub DESTROY
2693     my $self = shift;
2695     if ( $self->_logopen )
2696     {
2697         close $self->{fh};
2698     }
2701 package GITCVS::updater;
2703 ####
2704 #### Copyright The Open University UK - 2006.
2705 ####
2706 #### Authors: Martyn Smith    <martyn@catalyst.net.nz>
2707 ####          Martin Langhoff <martin@catalyst.net.nz>
2708 ####
2709 ####
2711 use strict;
2712 use warnings;
2713 use DBI;
2715 =head1 METHODS
2717 =cut
2719 =head2 new
2721 =cut
2722 sub new
2724     my $class = shift;
2725     my $config = shift;
2726     my $module = shift;
2727     my $log = shift;
2729     die "Need to specify a git repository" unless ( defined($config) and -d $config );
2730     die "Need to specify a module" unless ( defined($module) );
2732     $class = ref($class) || $class;
2734     my $self = {};
2736     bless $self, $class;
2738     $self->{valid_tables} = {'revision' => 1,
2739                              'revision_ix1' => 1,
2740                              'revision_ix2' => 1,
2741                              'head' => 1,
2742                              'head_ix1' => 1,
2743                              'properties' => 1,
2744                              'commitmsgs' => 1};
2746     $self->{module} = $module;
2747     $self->{git_path} = $config . "/";
2749     $self->{log} = $log;
2751     die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
2753     $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
2754         $cfg->{gitcvs}{dbdriver} || "SQLite";
2755     $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
2756         $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
2757     $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
2758         $cfg->{gitcvs}{dbuser} || "";
2759     $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
2760         $cfg->{gitcvs}{dbpass} || "";
2761     $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
2762         $cfg->{gitcvs}{dbtablenameprefix} || "";
2763     my %mapping = ( m => $module,
2764                     a => $state->{method},
2765                     u => getlogin || getpwuid($<) || $<,
2766                     G => $self->{git_path},
2767                     g => mangle_dirname($self->{git_path}),
2768                     );
2769     $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
2770     $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
2771     $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
2772     $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
2774     die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
2775     die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
2776     $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
2777                                 $self->{dbuser},
2778                                 $self->{dbpass});
2779     die "Error connecting to database\n" unless defined $self->{dbh};
2781     $self->{tables} = {};
2782     foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
2783     {
2784         $self->{tables}{$table} = 1;
2785     }
2787     # Construct the revision table if required
2788     unless ( $self->{tables}{$self->tablename("revision")} )
2789     {
2790         my $tablename = $self->tablename("revision");
2791         my $ix1name = $self->tablename("revision_ix1");
2792         my $ix2name = $self->tablename("revision_ix2");
2793         $self->{dbh}->do("
2794             CREATE TABLE $tablename (
2795                 name       TEXT NOT NULL,
2796                 revision   INTEGER NOT NULL,
2797                 filehash   TEXT NOT NULL,
2798                 commithash TEXT NOT NULL,
2799                 author     TEXT NOT NULL,
2800                 modified   TEXT NOT NULL,
2801                 mode       TEXT NOT NULL
2802             )
2803         ");
2804         $self->{dbh}->do("
2805             CREATE INDEX $ix1name
2806             ON $tablename (name,revision)
2807         ");
2808         $self->{dbh}->do("
2809             CREATE INDEX $ix2name
2810             ON $tablename (name,commithash)
2811         ");
2812     }
2814     # Construct the head table if required
2815     unless ( $self->{tables}{$self->tablename("head")} )
2816     {
2817         my $tablename = $self->tablename("head");
2818         my $ix1name = $self->tablename("head_ix1");
2819         $self->{dbh}->do("
2820             CREATE TABLE $tablename (
2821                 name       TEXT NOT NULL,
2822                 revision   INTEGER NOT NULL,
2823                 filehash   TEXT NOT NULL,
2824                 commithash TEXT NOT NULL,
2825                 author     TEXT NOT NULL,
2826                 modified   TEXT NOT NULL,
2827                 mode       TEXT NOT NULL
2828             )
2829         ");
2830         $self->{dbh}->do("
2831             CREATE INDEX $ix1name
2832             ON $tablename (name)
2833         ");
2834     }
2836     # Construct the properties table if required
2837     unless ( $self->{tables}{$self->tablename("properties")} )
2838     {
2839         my $tablename = $self->tablename("properties");
2840         $self->{dbh}->do("
2841             CREATE TABLE $tablename (
2842                 key        TEXT NOT NULL PRIMARY KEY,
2843                 value      TEXT
2844             )
2845         ");
2846     }
2848     # Construct the commitmsgs table if required
2849     unless ( $self->{tables}{$self->tablename("commitmsgs")} )
2850     {
2851         my $tablename = $self->tablename("commitmsgs");
2852         $self->{dbh}->do("
2853             CREATE TABLE $tablename (
2854                 key        TEXT NOT NULL PRIMARY KEY,
2855                 value      TEXT
2856             )
2857         ");
2858     }
2860     return $self;
2863 =head2 tablename
2865 =cut
2866 sub tablename
2868     my $self = shift;
2869     my $name = shift;
2871     if (exists $self->{valid_tables}{$name}) {
2872         return $self->{dbtablenameprefix} . $name;
2873     } else {
2874         return undef;
2875     }
2878 =head2 update
2880 =cut
2881 sub update
2883     my $self = shift;
2885     # first lets get the commit list
2886     $ENV{GIT_DIR} = $self->{git_path};
2888     my $commitsha1 = `git rev-parse $self->{module}`;
2889     chomp $commitsha1;
2891     my $commitinfo = `git cat-file commit $self->{module} 2>&1`;
2892     unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2893     {
2894         die("Invalid module '$self->{module}'");
2895     }
2898     my $git_log;
2899     my $lastcommit = $self->_get_prop("last_commit");
2901     if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
2902          return 1;
2903     }
2905     # Start exclusive lock here...
2906     $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2908     # TODO: log processing is memory bound
2909     # if we can parse into a 2nd file that is in reverse order
2910     # we can probably do something really efficient
2911     my @git_log_params = ('--pretty', '--parents', '--topo-order');
2913     if (defined $lastcommit) {
2914         push @git_log_params, "$lastcommit..$self->{module}";
2915     } else {
2916         push @git_log_params, $self->{module};
2917     }
2918     # git-rev-list is the backend / plumbing version of git-log
2919     open(GITLOG, '-|', 'git-rev-list', @git_log_params) or die "Cannot call git-rev-list: $!";
2921     my @commits;
2923     my %commit = ();
2925     while ( <GITLOG> )
2926     {
2927         chomp;
2928         if (m/^commit\s+(.*)$/) {
2929             # on ^commit lines put the just seen commit in the stack
2930             # and prime things for the next one
2931             if (keys %commit) {
2932                 my %copy = %commit;
2933                 unshift @commits, \%copy;
2934                 %commit = ();
2935             }
2936             my @parents = split(m/\s+/, $1);
2937             $commit{hash} = shift @parents;
2938             $commit{parents} = \@parents;
2939         } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2940             # on rfc822-like lines seen before we see any message,
2941             # lowercase the entry and put it in the hash as key-value
2942             $commit{lc($1)} = $2;
2943         } else {
2944             # message lines - skip initial empty line
2945             # and trim whitespace
2946             if (!exists($commit{message}) && m/^\s*$/) {
2947                 # define it to mark the end of headers
2948                 $commit{message} = '';
2949                 next;
2950             }
2951             s/^\s+//; s/\s+$//; # trim ws
2952             $commit{message} .= $_ . "\n";
2953         }
2954     }
2955     close GITLOG;
2957     unshift @commits, \%commit if ( keys %commit );
2959     # Now all the commits are in the @commits bucket
2960     # ordered by time DESC. for each commit that needs processing,
2961     # determine whether it's following the last head we've seen or if
2962     # it's on its own branch, grab a file list, and add whatever's changed
2963     # NOTE: $lastcommit refers to the last commit from previous run
2964     #       $lastpicked is the last commit we picked in this run
2965     my $lastpicked;
2966     my $head = {};
2967     if (defined $lastcommit) {
2968         $lastpicked = $lastcommit;
2969     }
2971     my $committotal = scalar(@commits);
2972     my $commitcount = 0;
2974     # Load the head table into $head (for cached lookups during the update process)
2975     foreach my $file ( @{$self->gethead()} )
2976     {
2977         $head->{$file->{name}} = $file;
2978     }
2980     foreach my $commit ( @commits )
2981     {
2982         $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2983         if (defined $lastpicked)
2984         {
2985             if (!in_array($lastpicked, @{$commit->{parents}}))
2986             {
2987                 # skip, we'll see this delta
2988                 # as part of a merge later
2989                 # warn "skipping off-track  $commit->{hash}\n";
2990                 next;
2991             } elsif (@{$commit->{parents}} > 1) {
2992                 # it is a merge commit, for each parent that is
2993                 # not $lastpicked, see if we can get a log
2994                 # from the merge-base to that parent to put it
2995                 # in the message as a merge summary.
2996                 my @parents = @{$commit->{parents}};
2997                 foreach my $parent (@parents) {
2998                     # git-merge-base can potentially (but rarely) throw
2999                     # several candidate merge bases. let's assume
3000                     # that the first one is the best one.
3001                     if ($parent eq $lastpicked) {
3002                         next;
3003                     }
3004                     my $base = eval {
3005                             safe_pipe_capture('git-merge-base',
3006                                                  $lastpicked, $parent);
3007                     };
3008                     # The two branches may not be related at all,
3009                     # in which case merge base simply fails to find
3010                     # any, but that's Ok.
3011                     next if ($@);
3013                     chomp $base;
3014                     if ($base) {
3015                         my @merged;
3016                         # print "want to log between  $base $parent \n";
3017                         open(GITLOG, '-|', 'git-log', '--pretty=medium', "$base..$parent")
3018                           or die "Cannot call git-log: $!";
3019                         my $mergedhash;
3020                         while (<GITLOG>) {
3021                             chomp;
3022                             if (!defined $mergedhash) {
3023                                 if (m/^commit\s+(.+)$/) {
3024                                     $mergedhash = $1;
3025                                 } else {
3026                                     next;
3027                                 }
3028                             } else {
3029                                 # grab the first line that looks non-rfc822
3030                                 # aka has content after leading space
3031                                 if (m/^\s+(\S.*)$/) {
3032                                     my $title = $1;
3033                                     $title = substr($title,0,100); # truncate
3034                                     unshift @merged, "$mergedhash $title";
3035                                     undef $mergedhash;
3036                                 }
3037                             }
3038                         }
3039                         close GITLOG;
3040                         if (@merged) {
3041                             $commit->{mergemsg} = $commit->{message};
3042                             $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3043                             foreach my $summary (@merged) {
3044                                 $commit->{mergemsg} .= "\t$summary\n";
3045                             }
3046                             $commit->{mergemsg} .= "\n\n";
3047                             # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3048                         }
3049                     }
3050                 }
3051             }
3052         }
3054         # convert the date to CVS-happy format
3055         $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3057         if ( defined ( $lastpicked ) )
3058         {
3059             my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
3060             local ($/) = "\0";
3061             while ( <FILELIST> )
3062             {
3063                 chomp;
3064                 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3065                 {
3066                     die("Couldn't process git-diff-tree line : $_");
3067                 }
3068                 my ($mode, $hash, $change) = ($1, $2, $3);
3069                 my $name = <FILELIST>;
3070                 chomp($name);
3072                 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3074                 my $git_perms = "";
3075                 $git_perms .= "r" if ( $mode & 4 );
3076                 $git_perms .= "w" if ( $mode & 2 );
3077                 $git_perms .= "x" if ( $mode & 1 );
3078                 $git_perms = "rw" if ( $git_perms eq "" );
3080                 if ( $change eq "D" )
3081                 {
3082                     #$log->debug("DELETE   $name");
3083                     $head->{$name} = {
3084                         name => $name,
3085                         revision => $head->{$name}{revision} + 1,
3086                         filehash => "deleted",
3087                         commithash => $commit->{hash},
3088                         modified => $commit->{date},
3089                         author => $commit->{author},
3090                         mode => $git_perms,
3091                     };
3092                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3093                 }
3094                 elsif ( $change eq "M" || $change eq "T" )
3095                 {
3096                     #$log->debug("MODIFIED $name");
3097                     $head->{$name} = {
3098                         name => $name,
3099                         revision => $head->{$name}{revision} + 1,
3100                         filehash => $hash,
3101                         commithash => $commit->{hash},
3102                         modified => $commit->{date},
3103                         author => $commit->{author},
3104                         mode => $git_perms,
3105                     };
3106                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3107                 }
3108                 elsif ( $change eq "A" )
3109                 {
3110                     #$log->debug("ADDED    $name");
3111                     $head->{$name} = {
3112                         name => $name,
3113                         revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
3114                         filehash => $hash,
3115                         commithash => $commit->{hash},
3116                         modified => $commit->{date},
3117                         author => $commit->{author},
3118                         mode => $git_perms,
3119                     };
3120                     $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3121                 }
3122                 else
3123                 {
3124                     $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3125                     die;
3126                 }
3127             }
3128             close FILELIST;
3129         } else {
3130             # this is used to detect files removed from the repo
3131             my $seen_files = {};
3133             my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
3134             local $/ = "\0";
3135             while ( <FILELIST> )
3136             {
3137                 chomp;
3138                 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3139                 {
3140                     die("Couldn't process git-ls-tree line : $_");
3141                 }
3143                 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3145                 $seen_files->{$git_filename} = 1;
3147                 my ( $oldhash, $oldrevision, $oldmode ) = (
3148                     $head->{$git_filename}{filehash},
3149                     $head->{$git_filename}{revision},
3150                     $head->{$git_filename}{mode}
3151                 );
3153                 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3154                 {
3155                     $git_perms = "";
3156                     $git_perms .= "r" if ( $1 & 4 );
3157                     $git_perms .= "w" if ( $1 & 2 );
3158                     $git_perms .= "x" if ( $1 & 1 );
3159                 } else {
3160                     $git_perms = "rw";
3161                 }
3163                 # unless the file exists with the same hash, we need to update it ...
3164                 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
3165                 {
3166                     my $newrevision = ( $oldrevision or 0 ) + 1;
3168                     $head->{$git_filename} = {
3169                         name => $git_filename,
3170                         revision => $newrevision,
3171                         filehash => $git_hash,
3172                         commithash => $commit->{hash},
3173                         modified => $commit->{date},
3174                         author => $commit->{author},
3175                         mode => $git_perms,
3176                     };
3179                     $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
3180                 }
3181             }
3182             close FILELIST;
3184             # Detect deleted files
3185             foreach my $file ( keys %$head )
3186             {
3187                 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
3188                 {
3189                     $head->{$file}{revision}++;
3190                     $head->{$file}{filehash} = "deleted";
3191                     $head->{$file}{commithash} = $commit->{hash};
3192                     $head->{$file}{modified} = $commit->{date};
3193                     $head->{$file}{author} = $commit->{author};
3195                     $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
3196                 }
3197             }
3198             # END : "Detect deleted files"
3199         }
3202         if (exists $commit->{mergemsg})
3203         {
3204             $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3205         }
3207         $lastpicked = $commit->{hash};
3209         $self->_set_prop("last_commit", $commit->{hash});
3210     }
3212     $self->delete_head();
3213     foreach my $file ( keys %$head )
3214     {
3215         $self->insert_head(
3216             $file,
3217             $head->{$file}{revision},
3218             $head->{$file}{filehash},
3219             $head->{$file}{commithash},
3220             $head->{$file}{modified},
3221             $head->{$file}{author},
3222             $head->{$file}{mode},
3223         );
3224     }
3225     # invalidate the gethead cache
3226     $self->{gethead_cache} = undef;
3229     # Ending exclusive lock here
3230     $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
3233 sub insert_rev
3235     my $self = shift;
3236     my $name = shift;
3237     my $revision = shift;
3238     my $filehash = shift;
3239     my $commithash = shift;
3240     my $modified = shift;
3241     my $author = shift;
3242     my $mode = shift;
3243     my $tablename = $self->tablename("revision");
3245     my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3246     $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3249 sub insert_mergelog
3251     my $self = shift;
3252     my $key = shift;
3253     my $value = shift;
3254     my $tablename = $self->tablename("commitmsgs");
3256     my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3257     $insert_mergelog->execute($key, $value);
3260 sub delete_head
3262     my $self = shift;
3263     my $tablename = $self->tablename("head");
3265     my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
3266     $delete_head->execute();
3269 sub insert_head
3271     my $self = shift;
3272     my $name = shift;
3273     my $revision = shift;
3274     my $filehash = shift;
3275     my $commithash = shift;
3276     my $modified = shift;
3277     my $author = shift;
3278     my $mode = shift;
3279     my $tablename = $self->tablename("head");
3281     my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
3282     $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
3285 sub _headrev
3287     my $self = shift;
3288     my $filename = shift;
3289     my $tablename = $self->tablename("head");
3291     my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM $tablename WHERE name=?",{},1);
3292     $db_query->execute($filename);
3293     my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
3295     return ( $hash, $revision, $mode );
3298 sub _get_prop
3300     my $self = shift;
3301     my $key = shift;
3302     my $tablename = $self->tablename("properties");
3304     my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3305     $db_query->execute($key);
3306     my ( $value ) = $db_query->fetchrow_array;
3308     return $value;
3311 sub _set_prop
3313     my $self = shift;
3314     my $key = shift;
3315     my $value = shift;
3316     my $tablename = $self->tablename("properties");
3318     my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3319     $db_query->execute($value, $key);
3321     unless ( $db_query->rows )
3322     {
3323         $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3324         $db_query->execute($key, $value);
3325     }
3327     return $value;
3330 =head2 gethead
3332 =cut
3334 sub gethead
3336     my $self = shift;
3337     my $tablename = $self->tablename("head");
3339     return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
3341     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3342     $db_query->execute();
3344     my $tree = [];
3345     while ( my $file = $db_query->fetchrow_hashref )
3346     {
3347         push @$tree, $file;
3348     }
3350     $self->{gethead_cache} = $tree;
3352     return $tree;
3355 =head2 getlog
3357 =cut
3359 sub getlog
3361     my $self = shift;
3362     my $filename = shift;
3363     my $tablename = $self->tablename("revision");
3365     my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3366     $db_query->execute($filename);
3368     my $tree = [];
3369     while ( my $file = $db_query->fetchrow_hashref )
3370     {
3371         push @$tree, $file;
3372     }
3374     return $tree;
3377 =head2 getmeta
3379 This function takes a filename (with path) argument and returns a hashref of
3380 metadata for that file.
3382 =cut
3384 sub getmeta
3386     my $self = shift;
3387     my $filename = shift;
3388     my $revision = shift;
3389     my $tablename_rev = $self->tablename("revision");
3390     my $tablename_head = $self->tablename("head");
3392     my $db_query;
3393     if ( defined($revision) and $revision =~ /^\d+$/ )
3394     {
3395         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND revision=?",{},1);
3396         $db_query->execute($filename, $revision);
3397     }
3398     elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3399     {
3400         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",{},1);
3401         $db_query->execute($filename, $revision);
3402     } else {
3403         $db_query = $self->{dbh}->prepare_cached("SELECT * FROM $tablename_head WHERE name=?",{},1);
3404         $db_query->execute($filename);
3405     }
3407     return $db_query->fetchrow_hashref;
3410 =head2 commitmessage
3412 this function takes a commithash and returns the commit message for that commit
3414 =cut
3415 sub commitmessage
3417     my $self = shift;
3418     my $commithash = shift;
3419     my $tablename = $self->tablename("commitmsgs");
3421     die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3423     my $db_query;
3424     $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3425     $db_query->execute($commithash);
3427     my ( $message ) = $db_query->fetchrow_array;
3429     if ( defined ( $message ) )
3430     {
3431         $message .= " " if ( $message =~ /\n$/ );
3432         return $message;
3433     }
3435     my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
3436     shift @lines while ( $lines[0] =~ /\S/ );
3437     $message = join("",@lines);
3438     $message .= " " if ( $message =~ /\n$/ );
3439     return $message;
3442 =head2 gethistory
3444 This function takes a filename (with path) argument and returns an arrayofarrays
3445 containing revision,filehash,commithash ordered by revision descending
3447 =cut
3448 sub gethistory
3450     my $self = shift;
3451     my $filename = shift;
3452     my $tablename = $self->tablename("revision");
3454     my $db_query;
3455     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3456     $db_query->execute($filename);
3458     return $db_query->fetchall_arrayref;
3461 =head2 gethistorydense
3463 This function takes a filename (with path) argument and returns an arrayofarrays
3464 containing revision,filehash,commithash ordered by revision descending.
3466 This version of gethistory skips deleted entries -- so it is useful for annotate.
3467 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3468 and other git tools that depend on it.
3470 =cut
3471 sub gethistorydense
3473     my $self = shift;
3474     my $filename = shift;
3475     my $tablename = $self->tablename("revision");
3477     my $db_query;
3478     $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3479     $db_query->execute($filename);
3481     return $db_query->fetchall_arrayref;
3484 =head2 in_array()
3486 from Array::PAT - mimics the in_array() function
3487 found in PHP. Yuck but works for small arrays.
3489 =cut
3490 sub in_array
3492     my ($check, @array) = @_;
3493     my $retval = 0;
3494     foreach my $test (@array){
3495         if($check eq $test){
3496             $retval =  1;
3497         }
3498     }
3499     return $retval;
3502 =head2 safe_pipe_capture
3504 an alternative to `command` that allows input to be passed as an array
3505 to work around shell problems with weird characters in arguments
3507 =cut
3508 sub safe_pipe_capture {
3510     my @output;
3512     if (my $pid = open my $child, '-|') {
3513         @output = (<$child>);
3514         close $child or die join(' ',@_).": $! $?";
3515     } else {
3516         exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3517     }
3518     return wantarray ? @output : join('',@output);
3521 =head2 mangle_dirname
3523 create a string from a directory name that is suitable to use as
3524 part of a filename, mainly by converting all chars except \w.- to _
3526 =cut
3527 sub mangle_dirname {
3528     my $dirname = shift;
3529     return unless defined $dirname;
3531     $dirname =~ s/[^\w.-]/_/g;
3533     return $dirname;
3536 =head2 mangle_tablename
3538 create a string from a that is suitable to use as part of an SQL table
3539 name, mainly by converting all chars except \w to _
3541 =cut
3542 sub mangle_tablename {
3543     my $tablename = shift;
3544     return unless defined $tablename;
3546     $tablename =~ s/[^\w_]/_/g;
3548     return $tablename;
3551 1;