]>
git.ipfire.org Git - thirdparty/git.git/blob - git-cvsserver.perl
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.
8 #### Copyright The Open University UK - 2006.
10 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
11 #### Martin Langhoff <martin@catalyst.net.nz>
14 #### Released under the GNU Public License, version 2.
23 use File
:: Temp qw
/tempdir tempfile/ ;
24 use File
:: Path qw
/rmtree/ ;
26 use Getopt
:: Long
qw(:config require_order no_ignore_case) ;
28 my $VERSION = '@ @GIT_VERSION @@' ;
30 my $log = GITCVS
:: log -> new ();
48 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
51 #### Definition and mappings of functions ####
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
,
66 'remove' => \
& req_remove
,
68 'update' => \
& req_update
,
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 'noop' => \
& req_EMPTY
,
80 'annotate' => \
& req_annotate
,
81 'Global_option' => \
& req_Globaloption
,
82 #'annotate' => \&req_CATCHALL,
85 ##############################################
88 # $state holds all the bits of information the clients sends us that could
89 # potentially be useful when it comes to actually _doing_ something.
90 my $state = { prependdir
=> '' };
92 # Work is for managing temporary working directory
95 state => undef , # undef, 1 (empty), 2 (with stuff)
102 $log -> info ( "--------------- STARTING -----------------" );
105 "Usage: git cvsserver [options] [pserver|server] [<directory> ...] \n " .
106 " --base-path <path> : Prepend to requested CVSROOT \n " .
107 " Can be read from GIT_CVSSERVER_BASE_PATH \n " .
108 " --strict-paths : Don't allow recursing into subdirectories \n " .
109 " --export-all : Don't check for gitcvs.enabled in config \n " .
110 " --version, -V : Print version information and exit \n " .
111 " --help, -h, -H : Print usage information and exit \n " .
113 "<directory> ... is a list of allowed directories. If no directories \n " .
114 "are given, all are allowed. This is an additional restriction, gitcvs \n " .
115 "access still needs to be enabled by the gitcvs.enabled config option. \n " .
116 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT. \n " ;
118 my @opts = ( 'help|h|H' , 'version|V' ,
119 'base-path=s' , 'strict-paths' , 'export-all' );
120 GetOptions
( $state , @opts )
123 if ( $state ->{ version
}) {
124 print "git-cvsserver version $VERSION \n " ;
127 if ( $state ->{ help
}) {
132 my $TEMP_DIR = tempdir
( CLEANUP
=> 1 );
133 $log -> debug ( "Temporary directory is ' $TEMP_DIR '" );
135 $state ->{ method
} = 'ext' ;
137 if ( $ARGV [ 0 ] eq 'pserver' ) {
138 $state ->{ method
} = 'pserver' ;
140 } elsif ( $ARGV [ 0 ] eq 'server' ) {
145 # everything else is a directory
146 $state ->{ allowed_roots
} = [ @ARGV ];
148 # don't export the whole system unless the users requests it
149 if ( $state ->{ 'export-all' } && ! @
{ $state ->{ allowed_roots
}}) {
150 die "--export-all can only be used together with an explicit whitelist \n " ;
153 # Environment handling for running under git-shell
154 if ( exists $ENV { GIT_CVSSERVER_BASE_PATH
}) {
155 if ( $state ->{ 'base-path' }) {
156 die "Cannot specify base path both ways. \n " ;
158 my $base_path = $ENV { GIT_CVSSERVER_BASE_PATH
};
159 $state ->{ 'base-path' } = $base_path ;
160 $log -> debug ( "Picked up base path ' $base_path ' from environment. \n " );
162 if ( exists $ENV { GIT_CVSSERVER_ROOT
}) {
163 if ( @
{ $state ->{ allowed_roots
}}) {
164 die "Cannot specify roots both ways: @ARGV \n " ;
166 my $allowed_root = $ENV { GIT_CVSSERVER_ROOT
};
167 $state ->{ allowed_roots
} = [ $allowed_root ];
168 $log -> debug ( "Picked up allowed root ' $allowed_root ' from environment. \n " );
171 # if we are called with a pserver argument,
172 # deal with the authentication cat before entering the
174 if ( $state ->{ method
} eq 'pserver' ) {
175 my $line = < STDIN
>; chomp $line ;
176 unless ( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/ ) {
177 die "E Do not understand $line - expecting BEGIN AUTH REQUEST \n " ;
180 $line = < STDIN
>; chomp $line ;
181 unless ( req_Root
( 'root' , $line )) { # reuse Root
182 print "E Invalid root $line \n " ;
185 $line = < STDIN
>; chomp $line ;
187 $line = < STDIN
>; chomp $line ;
188 my $password = $line ;
190 unless ( $user eq 'anonymous' ) {
191 # Trying to authenticate a user
192 if ( not exists $cfg ->{ gitcvs
}->{ authdb
}) {
193 print "E the repo config file needs a [gitcvs.authdb] section with a filename \n " ;
194 print "I HATE YOU \n " ;
198 open PASSWD
, "< $cfg ->{gitcvs}->{authdb}" or die $!;
200 if ( m{^\Q$user\E:(.*)} ) {
201 if ( crypt ( $user , $1 ) eq $1 ) {
207 print "I HATE YOU \n " ;
210 # else fall through to LOVE
213 # For checking whether the user is anonymous on commit
214 $state ->{ user
} = $user ;
216 $line = < STDIN
>; chomp $line ;
217 unless ( $line eq "END $request REQUEST" ) {
218 die "E Do not understand $line -- expecting END $request REQUEST \n " ;
220 print "I LOVE YOU \n " ;
221 exit if $request eq 'VERIFICATION' ; # cvs login
222 # and now back to our regular programme...
225 # Keep going until the client closes the connection
230 # Check to see if we've seen this method, and call appropriate function.
231 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined ( $methods ->{ $1 }) )
233 # use the $methods hash to call the appropriate sub for this command
234 #$log->info("Method : $1");
235 &{ $methods ->{ $1 }}( $1 , $2 );
237 # log fatal because we don't understand this function. If this happens
238 # we're fairly screwed because we don't know if the client is expecting
239 # a response. If it is, the client will hang, we'll hang, and the whole
240 # thing will be custard.
241 $log -> fatal ( "Don't understand command $_ \n " );
242 die ( "Unknown command $_ " );
246 $log -> debug ( "Processing time : user=" . ( times )[ 0 ] . " system=" . ( times )[ 1 ]);
247 $log -> info ( "--------------- FINISH -----------------" );
252 # Magic catchall method.
253 # This is the method that will handle all commands we haven't yet
254 # implemented. It simply sends a warning to the log file indicating a
255 # command that hasn't been implemented has been invoked.
258 my ( $cmd , $data ) = @_ ;
259 $log -> warn ( "Unhandled command : req_ $cmd : $data " );
262 # This method invariably succeeds with an empty response.
269 # Response expected: no. Tell the server which CVSROOT to use. Note that
270 # pathname is a local directory and not a fully qualified CVSROOT variable.
271 # pathname must already exist; if creating a new root, use the init
272 # request, not Root. pathname does not include the hostname of the server,
273 # how to access the server, etc.; by the time the CVS protocol is in use,
274 # connection, authentication, etc., are already taken care of. The Root
275 # request must be sent only once, and it must be sent before any requests
276 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
279 my ( $cmd , $data ) = @_ ;
280 $log -> debug ( "req_Root : $data " );
282 unless ( $data =~ m
#^/#) {
283 print "error 1 Root must be an absolute pathname \n " ;
287 my $cvsroot = $state ->{ 'base-path' } || '' ;
291 if ( $state ->{ CVSROOT
}
292 && ( $state ->{ CVSROOT
} ne $cvsroot )) {
293 print "error 1 Conflicting roots specified \n " ;
297 $state ->{ CVSROOT
} = $cvsroot ;
299 $ENV { GIT_DIR
} = $state ->{ CVSROOT
} . "/" ;
301 if ( @
{ $state ->{ allowed_roots
}}) {
303 foreach my $dir ( @
{ $state ->{ allowed_roots
}}) {
304 next unless $dir =~ m
#^/#;
306 if ( $state ->{ 'strict-paths' }) {
307 if ( $ENV { GIT_DIR
} =~ m
#^\Q$dir\E/?$#) {
311 } elsif ( $ENV { GIT_DIR
} =~ m
#^\Q$dir\E(/?$|/)#) {
318 print "E $ENV {GIT_DIR} does not seem to be a valid GIT repository \n " ;
320 print "error 1 $ENV {GIT_DIR} is not a valid repository \n " ;
325 unless (- d
$ENV { GIT_DIR
} && - e
$ENV { GIT_DIR
}. 'HEAD' ) {
326 print "E $ENV {GIT_DIR} does not seem to be a valid GIT repository \n " ;
328 print "error 1 $ENV {GIT_DIR} is not a valid repository \n " ;
332 my @gitvars = `git config -l` ;
334 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly. \n " ;
336 print "error 1 - problem executing git-config \n " ;
339 foreach my $line ( @gitvars )
341 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
345 $cfg ->{ $1 }{ $2 }{ $3 } = $4 ;
349 my $enabled = ( $cfg ->{ gitcvs
}{ $state ->{ method
}}{ enabled
}
350 || $cfg ->{ gitcvs
}{ enabled
});
351 unless ( $state ->{ 'export-all' } ||
352 ( $enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i )) {
353 print "E GITCVS emulation needs to be enabled on this repo \n " ;
354 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1 \n " ;
356 print "error 1 GITCVS emulation disabled \n " ;
360 my $logfile = $cfg ->{ gitcvs
}{ $state ->{ method
}}{ logfile
} || $cfg ->{ gitcvs
}{ logfile
};
363 $log -> setfile ( $logfile );
371 # Global_option option \n
372 # Response expected: no. Transmit one of the global options `-q', `-Q',
373 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
374 # variations (such as combining of options) are allowed. For graceful
375 # handling of valid-requests, it is probably better to make new global
376 # options separate requests, rather than trying to add them to this
380 my ( $cmd , $data ) = @_ ;
381 $log -> debug ( "req_Globaloption : $data " );
382 $state ->{ globaloptions
}{ $data } = 1 ;
385 # Valid-responses request-list \n
386 # Response expected: no. Tell the server what responses the client will
387 # accept. request-list is a space separated list of tokens.
388 sub req_Validresponses
390 my ( $cmd , $data ) = @_ ;
391 $log -> debug ( "req_Validresponses : $data " );
393 # TODO : re-enable this, currently it's not particularly useful
394 #$state->{validresponses} = [ split /\s+/, $data ];
398 # Response expected: yes. Ask the server to send back a Valid-requests
400 sub req_validrequests
402 my ( $cmd , $data ) = @_ ;
404 $log -> debug ( "req_validrequests" );
406 $log -> debug ( "SEND : Valid-requests " . join ( " " , keys % $methods ));
407 $log -> debug ( "SEND : ok" );
409 print "Valid-requests " . join ( " " , keys % $methods ) . " \n " ;
413 # Directory local-directory \n
414 # Additional data: repository \n. Response expected: no. Tell the server
415 # what directory to use. The repository should be a directory name from a
416 # previous server response. Note that this both gives a default for Entry
417 # and Modified and also for ci and the other commands; normal usage is to
418 # send Directory for each directory in which there will be an Entry or
419 # Modified, and then a final Directory for the original directory, then the
420 # command. The local-directory is relative to the top level at which the
421 # command is occurring (i.e. the last Directory which is sent before the
422 # command); to indicate that top level, `.' should be sent for
426 my ( $cmd , $data ) = @_ ;
428 my $repository = < STDIN
>;
432 $state ->{ localdir
} = $data ;
433 $state ->{ repository
} = $repository ;
434 $state ->{ path
} = $repository ;
435 $state ->{ path
} =~ s/^\Q$state->{CVSROOT}\E\// /;
436 $state ->{ module
} = $1 if ( $state ->{ path
} =~ s/^(.*?)(\/|$)/ /);
437 $state ->{ path
} .= "/" if ( $state ->{ path
} =~ / \S
/ );
439 $state ->{ directory
} = $state ->{ localdir
};
440 $state ->{ directory
} = "" if ( $state ->{ directory
} eq "." );
441 $state ->{ directory
} .= "/" if ( $state ->{ directory
} =~ / \S
/ );
443 if ( ( not defined ( $state ->{ prependdir
}) or $state ->{ prependdir
} eq '' ) and $state ->{ localdir
} eq "." and $state ->{ path
} =~ /\S/ )
445 $log -> info ( "Setting prepend to ' $state ->{path}'" );
446 $state ->{ prependdir
} = $state ->{ path
};
447 foreach my $entry ( keys %{ $state ->{ entries
}} )
449 $state ->{ entries
}{ $state ->{ prependdir
} . $entry } = $state ->{ entries
}{ $entry };
450 delete $state ->{ entries
}{ $entry };
454 if ( defined ( $state ->{ prependdir
} ) )
456 $log -> debug ( "Prepending ' $state ->{prependdir}' to state|directory" );
457 $state ->{ directory
} = $state ->{ prependdir
} . $state ->{ directory
}
459 $log -> debug ( "req_Directory : localdir= $data repository= $repository path= $state ->{path} directory= $state ->{directory} module= $state ->{module}" );
462 # Entry entry-line \n
463 # Response expected: no. Tell the server what version of a file is on the
464 # local machine. The name in entry-line is a name relative to the directory
465 # most recently specified with Directory. If the user is operating on only
466 # some files in a directory, Entry requests for only those files need be
467 # included. If an Entry request is sent without Modified, Is-modified, or
468 # Unchanged, it means the file is lost (does not exist in the working
469 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
470 # are sent for the same file, Entry must be sent first. For a given file,
471 # one can send Modified, Is-modified, or Unchanged, but not more than one
475 my ( $cmd , $data ) = @_ ;
477 #$log->debug("req_Entry : $data");
479 my @data = split ( /\/ /, $data );
481 $state ->{ entries
}{ $state ->{ directory
}. $data [ 1 ]} = {
482 revision
=> $data [ 2 ],
483 conflict
=> $data [ 3 ],
485 tag_or_date
=> $data [ 5 ],
488 $log -> info ( "Received entry line ' $data ' => '" . $state ->{ directory
} . $data [ 1 ] . "'" );
491 # Questionable filename \n
492 # Response expected: no. Additional data: no. Tell the server to check
493 # whether filename should be ignored, and if not, next time the server
494 # sends responses, send (in a M response) `?' followed by the directory and
495 # filename. filename must not contain `/'; it needs to be a file in the
496 # directory named by the most recent Directory request.
499 my ( $cmd , $data ) = @_ ;
501 $log -> debug ( "req_Questionable : $data " );
502 $state ->{ entries
}{ $state ->{ directory
}. $data }{ questionable
} = 1 ;
506 # Response expected: yes. Add a file or directory. This uses any previous
507 # Argument, Directory, Entry, or Modified requests, if they have been sent.
508 # The last Directory sent specifies the working directory at the time of
509 # the operation. To add a directory, send the directory to be added using
510 # Directory and Argument requests.
513 my ( $cmd , $data ) = @_ ;
517 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
520 argsfromdir
( $updater );
524 foreach my $filename ( @
{ $state ->{ args
}} )
526 $filename = filecleanup
( $filename );
528 my $meta = $updater -> getmeta ( $filename );
529 my $wrev = revparse
( $filename );
531 if ( $wrev && $meta && ( $wrev < 0 ))
533 # previously removed file, add back
534 $log -> info ( "added file $filename was previously removed, send 1. $meta ->{revision}" );
536 print "MT +updated \n " ;
537 print "MT text U \n " ;
538 print "MT fname $filename \n " ;
539 print "MT newline \n " ;
540 print "MT -updated \n " ;
542 unless ( $state ->{ globaloptions
}{- n
} )
544 my ( $filepart , $dirpart ) = filenamesplit
( $filename , 1 );
546 print "Created $dirpart \n " ;
547 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename \n " ;
549 # this is an "entries" line
550 my $kopts = kopts_from_path
( $filename , "sha1" , $meta ->{ filehash
});
551 $log -> debug ( "/ $filepart /1. $meta ->{revision}// $kopts /" );
552 print "/ $filepart /1. $meta ->{revision}// $kopts / \n " ;
554 $log -> debug ( "SEND : u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode}" );
555 print "u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode} \n " ;
557 transmitfile
( $meta ->{ filehash
});
563 unless ( defined ( $state ->{ entries
}{ $filename }{ modified_filename
} ) )
565 print "E cvs add: nothing known about ` $filename ' \n " ;
568 # TODO : check we're not squashing an already existing file
569 if ( defined ( $state ->{ entries
}{ $filename }{ revision
} ) )
571 print "E cvs add: ` $filename ' has already been entered \n " ;
575 my ( $filepart , $dirpart ) = filenamesplit
( $filename , 1 );
577 print "E cvs add: scheduling file ` $filename ' for addition \n " ;
579 print "Checked-in $dirpart \n " ;
581 my $kopts = kopts_from_path
( $filename , "file" ,
582 $state ->{ entries
}{ $filename }{ modified_filename
});
583 print "/ $filepart /0// $kopts / \n " ;
585 my $requestedKopts = $state ->{ opt
}{ k
};
586 if ( defined ( $requestedKopts ))
588 $requestedKopts = "-k $requestedKopts " ;
592 $requestedKopts = "" ;
594 if ( $kopts ne $requestedKopts )
596 $log -> warn ( "Ignoring requested -k=' $requestedKopts '"
597 . " for ' $filename '; detected -k=' $kopts ' instead" );
598 #TODO: Also have option to send warning to user?
604 if ( $addcount == 1 )
606 print "E cvs add: use `cvs commit' to add this file permanently \n " ;
608 elsif ( $addcount > 1 )
610 print "E cvs add: use `cvs commit' to add these files permanently \n " ;
617 # Response expected: yes. Remove a file. This uses any previous Argument,
618 # Directory, Entry, or Modified requests, if they have been sent. The last
619 # Directory sent specifies the working directory at the time of the
620 # operation. Note that this request does not actually do anything to the
621 # repository; the only effect of a successful remove request is to supply
622 # the client with a new entries line containing `-' to indicate a removed
623 # file. In fact, the client probably could perform this operation without
624 # contacting the server, although using remove may cause the server to
625 # perform a few more checks. The client sends a subsequent ci request to
626 # actually record the removal in the repository.
629 my ( $cmd , $data ) = @_ ;
633 # Grab a handle to the SQLite db and do any necessary updates
634 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
637 #$log->debug("add state : " . Dumper($state));
641 foreach my $filename ( @
{ $state ->{ args
}} )
643 $filename = filecleanup
( $filename );
645 if ( defined ( $state ->{ entries
}{ $filename }{ unchanged
} ) or defined ( $state ->{ entries
}{ $filename }{ modified_filename
} ) )
647 print "E cvs remove: file ` $filename ' still in working directory \n " ;
651 my $meta = $updater -> getmeta ( $filename );
652 my $wrev = revparse
( $filename );
654 unless ( defined ( $wrev ) )
656 print "E cvs remove: nothing known about ` $filename ' \n " ;
660 if ( defined ( $wrev ) and $wrev < 0 )
662 print "E cvs remove: file ` $filename ' already scheduled for removal \n " ;
666 unless ( $wrev == $meta ->{ revision
} )
668 # TODO : not sure if the format of this message is quite correct.
669 print "E cvs remove: Up to date check failed for ` $filename ' \n " ;
674 my ( $filepart , $dirpart ) = filenamesplit
( $filename , 1 );
676 print "E cvs remove: scheduling ` $filename ' for removal \n " ;
678 print "Checked-in $dirpart \n " ;
680 my $kopts = kopts_from_path
( $filename , "sha1" , $meta ->{ filehash
});
681 print "/ $filepart /-1. $wrev // $kopts / \n " ;
688 print "E cvs remove: use `cvs commit' to remove this file permanently \n " ;
690 elsif ( $rmcount > 1 )
692 print "E cvs remove: use `cvs commit' to remove these files permanently \n " ;
698 # Modified filename \n
699 # Response expected: no. Additional data: mode, \n, file transmission. Send
700 # the server a copy of one locally modified file. filename is a file within
701 # the most recent directory sent with Directory; it must not contain `/'.
702 # If the user is operating on only some files in a directory, only those
703 # files need to be included. This can also be sent without Entry, if there
704 # is no entry for the file.
707 my ( $cmd , $data ) = @_ ;
711 or ( print "E end of file reading mode for $data \n " ), return ;
715 or ( print "E end of file reading size of $data \n " ), return ;
718 # Grab config information
719 my $blocksize = 8192 ;
720 my $bytesleft = $size ;
723 # Get a filehandle/name to write it to
724 my ( $fh , $filename ) = tempfile
( DIR
=> $TEMP_DIR );
726 # Loop over file data writing out to temporary file.
729 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
730 read STDIN
, $tmp , $blocksize ;
732 $bytesleft -= $blocksize ;
736 or ( print "E failed to write temporary, $filename : $! \n " ), return ;
738 # Ensure we have something sensible for the file mode
739 if ( $mode =~ /u=(\w+)/ )
746 # Save the file data in $state
747 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_filename
} = $filename ;
748 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_mode
} = $mode ;
749 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_hash
} = `git hash-object $filename ` ;
750 $state ->{ entries
}{ $state ->{ directory
}. $data }{ modified_hash
} =~ s/\s.*$//s ;
752 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
755 # Unchanged filename \n
756 # Response expected: no. Tell the server that filename has not been
757 # modified in the checked out directory. The filename is a file within the
758 # most recent directory sent with Directory; it must not contain `/'.
761 my ( $cmd , $data ) = @_ ;
763 $state ->{ entries
}{ $state ->{ directory
}. $data }{ unchanged
} = 1 ;
765 #$log->debug("req_Unchanged : $data");
769 # Response expected: no. Save argument for use in a subsequent command.
770 # Arguments accumulate until an argument-using command is given, at which
771 # point they are forgotten.
773 # Response expected: no. Append \n followed by text to the current argument
777 my ( $cmd , $data ) = @_ ;
779 # Argumentx means: append to last Argument (with a newline in front)
781 $log -> debug ( " $cmd : $data " );
783 if ( $cmd eq 'Argumentx' ) {
784 ${ $state ->{ arguments
}}[$ #{$state->{arguments}}] .= "\n" . $data;
786 push @
{ $state ->{ arguments
}}, $data ;
791 # Response expected: yes. Expand the modules which are specified in the
792 # arguments. Returns the data in Module-expansion responses. Note that the
793 # server can assume that this is checkout or export, not rtag or rdiff; the
794 # latter do not access the working directory and thus have no need to
795 # expand modules on the client side. Expand may not be the best word for
796 # what this request does. It does not necessarily tell you all the files
797 # contained in a module, for example. Basically it is a way of telling you
798 # which working directories the server needs to know about in order to
799 # handle a checkout of the specified modules. For example, suppose that the
800 # server has a module defined by
801 # aliasmodule -a 1dir
802 # That is, one can check out aliasmodule and it will take 1dir in the
803 # repository and check it out to 1dir in the working directory. Now suppose
804 # the client already has this module checked out and is planning on using
805 # the co request to update it. Without using expand-modules, the client
806 # would have two bad choices: it could either send information about all
807 # working directories under the current directory, which could be
808 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
809 # stands for 1dir, and neglect to send information for 1dir, which would
810 # lead to incorrect operation. With expand-modules, the client would first
811 # ask for the module to be expanded:
812 sub req_expandmodules
814 my ( $cmd , $data ) = @_ ;
818 $log -> debug ( "req_expandmodules : " . ( defined ( $data ) ?
$data : "[NULL]" ) );
820 unless ( ref $state ->{ arguments
} eq "ARRAY" )
826 foreach my $module ( @
{ $state ->{ arguments
}} )
828 $log -> debug ( "SEND : Module-expansion $module " );
829 print "Module-expansion $module \n " ;
837 # Response expected: yes. Get files from the repository. This uses any
838 # previous Argument, Directory, Entry, or Modified requests, if they have
839 # been sent. Arguments to this command are module names; the client cannot
840 # know what directories they correspond to except by (1) just sending the
841 # co request, and then seeing what directory names the server sends back in
842 # its responses, and (2) the expand-modules request.
845 my ( $cmd , $data ) = @_ ;
849 # Provide list of modules, if -c was used.
850 if ( exists $state ->{ opt
}{ c
}) {
851 my $showref = `git show-ref --heads` ;
852 for my $line ( split ' \n ' , $showref ) {
853 if ( $line =~ m
% refs
/heads/ (.*)$% ) {
861 my $module = $state ->{ args
}[ 0 ];
862 $state ->{ module
} = $module ;
863 my $checkout_path = $module ;
865 # use the user specified directory if we're given it
866 $checkout_path = $state ->{ opt
}{ d
} if ( exists ( $state ->{ opt
}{ d
} ) );
868 $log -> debug ( "req_co : " . ( defined ( $data ) ?
$data : "[NULL]" ) );
870 $log -> info ( "Checking out module ' $module ' ( $state ->{CVSROOT}) to ' $checkout_path '" );
872 $ENV { GIT_DIR
} = $state ->{ CVSROOT
} . "/" ;
874 # Grab a handle to the SQLite db and do any necessary updates
875 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $module , $log );
878 $checkout_path =~ s
|/$||; # get rid of trailing slashes
880 # Eclipse seems to need the Clear-sticky command
881 # to prepare the 'Entries' file for the new directory.
882 print "Clear-sticky $checkout_path / \n " ;
883 print $state ->{ CVSROOT
} . "/ $module / \n " ;
884 print "Clear-static-directory $checkout_path / \n " ;
885 print $state ->{ CVSROOT
} . "/ $module / \n " ;
886 print "Clear-sticky $checkout_path / \n " ; # yes, twice
887 print $state ->{ CVSROOT
} . "/ $module / \n " ;
888 print "Template $checkout_path / \n " ;
889 print $state ->{ CVSROOT
} . "/ $module / \n " ;
892 # instruct the client that we're checking out to $checkout_path
893 print "E cvs checkout: Updating $checkout_path \n " ;
900 my ( $dir , $repodir , $remotedir , $seendirs ) = @_ ;
901 my $parent = dirname
( $dir );
904 $remotedir =~ s
|/+$||;
906 $log -> debug ( "announcedir $dir , $repodir , $remotedir " );
908 if ( $parent eq '.' || $parent eq './' ) {
911 # recurse to announce unseen parents first
912 if ( length ( $parent ) && ! exists ( $seendirs ->{ $parent })) {
913 prepdir
( $parent , $repodir , $remotedir , $seendirs );
915 # Announce that we are going to modify at the parent level
917 print "E cvs checkout: Updating $remotedir / $parent \n " ;
919 print "E cvs checkout: Updating $remotedir \n " ;
921 print "Clear-sticky $remotedir / $parent / \n " ;
922 print " $repodir / $parent / \n " ;
924 print "Clear-static-directory $remotedir / $dir / \n " ;
925 print " $repodir / $dir / \n " ;
926 print "Clear-sticky $remotedir / $parent / \n " ; # yes, twice
927 print " $repodir / $parent / \n " ;
928 print "Template $remotedir / $dir / \n " ;
929 print " $repodir / $dir / \n " ;
932 $seendirs ->{ $dir } = 1 ;
935 foreach my $git ( @
{ $updater -> gethead } )
937 # Don't want to check out deleted files
938 next if ( $git ->{ filehash
} eq "deleted" );
940 my $fullName = $git ->{ name
};
941 ( $git ->{ name
}, $git ->{ dir
} ) = filenamesplit
( $git ->{ name
});
943 if ( length ( $git ->{ dir
}) && $git ->{ dir
} ne './'
944 && $git ->{ dir
} ne $lastdir ) {
945 unless ( exists ( $seendirs { $git ->{ dir
}})) {
946 prepdir
( $git ->{ dir
}, $state ->{ CVSROOT
} . "/ $module /" ,
947 $checkout_path , \
%seendirs );
948 $lastdir = $git ->{ dir
};
949 $seendirs { $git ->{ dir
}} = 1 ;
951 print "E cvs checkout: Updating / $checkout_path / $git ->{dir} \n " ;
954 # modification time of this file
955 print "Mod-time $git ->{modified} \n " ;
957 # print some information to the client
958 if ( defined ( $git ->{ dir
} ) and $git ->{ dir
} ne "./" )
960 print "M U $checkout_path / $git ->{dir} $git ->{name} \n " ;
962 print "M U $checkout_path / $git ->{name} \n " ;
965 # instruct client we're sending a file to put in this path
966 print "Created $checkout_path /" . ( defined ( $git ->{ dir
} ) and $git ->{ dir
} ne "./" ?
$git ->{ dir
} . "/" : "" ) . " \n " ;
968 print $state ->{ CVSROOT
} . "/ $module /" . ( defined ( $git ->{ dir
} ) and $git ->{ dir
} ne "./" ?
$git ->{ dir
} . "/" : "" ) . " $git ->{name} \n " ;
970 # this is an "entries" line
971 my $kopts = kopts_from_path
( $fullName , "sha1" , $git ->{ filehash
});
972 print "/ $git ->{name}/1. $git ->{revision}// $kopts / \n " ;
974 print "u= $git ->{mode},g= $git ->{mode},o= $git ->{mode} \n " ;
977 transmitfile
( $git ->{ filehash
});
986 # Response expected: yes. Actually do a cvs update command. This uses any
987 # previous Argument, Directory, Entry, or Modified requests, if they have
988 # been sent. The last Directory sent specifies the working directory at the
989 # time of the operation. The -I option is not used--files which the client
990 # can decide whether to ignore are not mentioned and the client sends the
991 # Questionable request for others.
994 my ( $cmd , $data ) = @_ ;
996 $log -> debug ( "req_update : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1001 # It may just be a client exploring the available heads/modules
1002 # in that case, list them as top level directories and leave it
1003 # at that. Eclipse uses this technique to offer you a list of
1004 # projects (heads in this case) to checkout.
1006 if ( $state ->{ module
} eq '' ) {
1007 my $showref = `git show-ref --heads` ;
1008 print "E cvs update: Updating . \n " ;
1009 for my $line ( split ' \n ' , $showref ) {
1010 if ( $line =~ m
% refs
/heads/ (.*)$% ) {
1011 print "E cvs update: New directory ` $1 ' \n " ;
1019 # Grab a handle to the SQLite db and do any necessary updates
1020 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1024 argsfromdir
( $updater );
1026 #$log->debug("update state : " . Dumper($state));
1028 my $last_dirname = "///" ;
1030 # foreach file specified on the command line ...
1031 foreach my $filename ( @
{ $state ->{ args
}} )
1033 $filename = filecleanup
( $filename );
1035 $log -> debug ( "Processing file $filename " );
1037 unless ( $state ->{ globaloptions
}{- Q
} || $state ->{ globaloptions
}{- q
} )
1039 my $cur_dirname = dirname
( $filename );
1040 if ( $cur_dirname ne $last_dirname )
1042 $last_dirname = $cur_dirname ;
1043 if ( $cur_dirname eq "" )
1047 print "E cvs update: Updating $cur_dirname \n " ;
1051 # if we have a -C we should pretend we never saw modified stuff
1052 if ( exists ( $state ->{ opt
}{ C
} ) )
1054 delete $state ->{ entries
}{ $filename }{ modified_hash
};
1055 delete $state ->{ entries
}{ $filename }{ modified_filename
};
1056 $state ->{ entries
}{ $filename }{ unchanged
} = 1 ;
1060 if ( defined ( $state ->{ opt
}{ r
}) and $state ->{ opt
}{ r
} =~ /^1\.(\d+)/ )
1062 $meta = $updater -> getmeta ( $filename , $1 );
1064 $meta = $updater -> getmeta ( $filename );
1067 # If -p was given, "print" the contents of the requested revision.
1068 if ( exists ( $state ->{ opt
}{ p
} ) ) {
1069 if ( defined ( $meta ->{ revision
} ) ) {
1070 $log -> info ( "Printing ' $filename ' revision " . $meta ->{ revision
});
1072 transmitfile
( $meta ->{ filehash
}, { print => 1 });
1078 if ( ! defined $meta )
1087 my $oldmeta = $meta ;
1089 my $wrev = revparse
( $filename );
1091 # If the working copy is an old revision, lets get that version too for comparison.
1092 if ( defined ( $wrev ) and $wrev != $meta ->{ revision
} )
1094 $oldmeta = $updater -> getmeta ( $filename , $wrev );
1097 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1099 # Files are up to date if the working copy and repo copy have the same revision,
1100 # and the working copy is unmodified _and_ the user hasn't specified -C
1101 next if ( defined ( $wrev )
1102 and defined ( $meta ->{ revision
})
1103 and $wrev == $meta ->{ revision
}
1104 and $state ->{ entries
}{ $filename }{ unchanged
}
1105 and not exists ( $state ->{ opt
}{ C
} ) );
1107 # If the working copy and repo copy have the same revision,
1108 # but the working copy is modified, tell the client it's modified
1109 if ( defined ( $wrev )
1110 and defined ( $meta ->{ revision
})
1111 and $wrev == $meta ->{ revision
}
1112 and defined ( $state ->{ entries
}{ $filename }{ modified_hash
})
1113 and not exists ( $state ->{ opt
}{ C
} ) )
1115 $log -> info ( "Tell the client the file is modified" );
1116 print "MT text M \n " ;
1117 print "MT fname $filename \n " ;
1118 print "MT newline \n " ;
1122 if ( $meta ->{ filehash
} eq "deleted" )
1124 my ( $filepart , $dirpart ) = filenamesplit
( $filename , 1 );
1126 $log -> info ( "Removing ' $filename ' from working copy (no longer in the repo)" );
1128 print "E cvs update: ` $filename ' is no longer in the repository \n " ;
1129 # Don't want to actually _DO_ the update if -n specified
1130 unless ( $state ->{ globaloptions
}{- n
} ) {
1131 print "Removed $dirpart \n " ;
1132 print " $filepart \n " ;
1135 elsif ( not defined ( $state ->{ entries
}{ $filename }{ modified_hash
} )
1136 or $state ->{ entries
}{ $filename }{ modified_hash
} eq $oldmeta ->{ filehash
}
1137 or $meta ->{ filehash
} eq 'added' )
1139 # normal update, just send the new revision (either U=Update,
1140 # or A=Add, or R=Remove)
1141 if ( defined ( $wrev ) && $wrev < 0 )
1143 $log -> info ( "Tell the client the file is scheduled for removal" );
1144 print "MT text R \n " ;
1145 print "MT fname $filename \n " ;
1146 print "MT newline \n " ;
1149 elsif ( (! defined ( $wrev ) || $wrev == 0 ) && (! defined ( $meta ->{ revision
}) || $meta ->{ revision
} == 0 ) )
1151 $log -> info ( "Tell the client the file is scheduled for addition" );
1152 print "MT text A \n " ;
1153 print "MT fname $filename \n " ;
1154 print "MT newline \n " ;
1159 $log -> info ( "Updating ' $filename ' to " . $meta ->{ revision
});
1160 print "MT +updated \n " ;
1161 print "MT text U \n " ;
1162 print "MT fname $filename \n " ;
1163 print "MT newline \n " ;
1164 print "MT -updated \n " ;
1167 my ( $filepart , $dirpart ) = filenamesplit
( $filename , 1 );
1169 # Don't want to actually _DO_ the update if -n specified
1170 unless ( $state ->{ globaloptions
}{- n
} )
1172 if ( defined ( $wrev ) )
1174 # instruct client we're sending a file to put in this path as a replacement
1175 print "Update-existing $dirpart \n " ;
1176 $log -> debug ( "Updating existing file 'Update-existing $dirpart '" );
1178 # instruct client we're sending a file to put in this path as a new file
1179 print "Clear-static-directory $dirpart \n " ;
1180 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $dirpart \n " ;
1181 print "Clear-sticky $dirpart \n " ;
1182 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $dirpart \n " ;
1184 $log -> debug ( "Creating new file 'Created $dirpart '" );
1185 print "Created $dirpart \n " ;
1187 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename \n " ;
1189 # this is an "entries" line
1190 my $kopts = kopts_from_path
( $filename , "sha1" , $meta ->{ filehash
});
1191 $log -> debug ( "/ $filepart /1. $meta ->{revision}// $kopts /" );
1192 print "/ $filepart /1. $meta ->{revision}// $kopts / \n " ;
1195 $log -> debug ( "SEND : u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode}" );
1196 print "u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode} \n " ;
1199 transmitfile
( $meta ->{ filehash
});
1202 $log -> info ( "Updating ' $filename '" );
1203 my ( $filepart , $dirpart ) = filenamesplit
( $meta ->{ name
}, 1 );
1205 my $mergeDir = setupTmpDir
();
1207 my $file_local = $filepart . ".mine" ;
1208 my $mergedFile = " $mergeDir / $file_local " ;
1209 system ( "ln" , "-s" , $state ->{ entries
}{ $filename }{ modified_filename
}, $file_local );
1210 my $file_old = $filepart . "." . $oldmeta ->{ revision
};
1211 transmitfile
( $oldmeta ->{ filehash
}, { targetfile
=> $file_old });
1212 my $file_new = $filepart . "." . $meta ->{ revision
};
1213 transmitfile
( $meta ->{ filehash
}, { targetfile
=> $file_new });
1215 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1216 $log -> info ( "Merging $file_local , $file_old , $file_new " );
1217 print "M Merging differences between 1. $oldmeta ->{revision} and 1. $meta ->{revision} into $filename \n " ;
1219 $log -> debug ( "Temporary directory for merge is $mergeDir " );
1221 my $return = system ( "git" , "merge-file" , $file_local , $file_old , $file_new );
1228 $log -> info ( "Merged successfully" );
1229 print "M M $filename \n " ;
1230 $log -> debug ( "Merged $dirpart " );
1232 # Don't want to actually _DO_ the update if -n specified
1233 unless ( $state ->{ globaloptions
}{- n
} )
1235 print "Merged $dirpart \n " ;
1236 $log -> debug ( $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename " );
1237 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename \n " ;
1238 my $kopts = kopts_from_path
( " $dirpart / $filepart " ,
1239 "file" , $mergedFile );
1240 $log -> debug ( "/ $filepart /1. $meta ->{revision}// $kopts /" );
1241 print "/ $filepart /1. $meta ->{revision}// $kopts / \n " ;
1244 elsif ( $return == 1 )
1246 $log -> info ( "Merged with conflicts" );
1247 print "E cvs update: conflicts found in $filename \n " ;
1248 print "M C $filename \n " ;
1250 # Don't want to actually _DO_ the update if -n specified
1251 unless ( $state ->{ globaloptions
}{- n
} )
1253 print "Merged $dirpart \n " ;
1254 print $state ->{ CVSROOT
} . "/ $state ->{module}/ $filename \n " ;
1255 my $kopts = kopts_from_path
( " $dirpart / $filepart " ,
1256 "file" , $mergedFile );
1257 print "/ $filepart /1. $meta ->{revision}/+/ $kopts / \n " ;
1262 $log -> warn ( "Merge failed" );
1266 # Don't want to actually _DO_ the update if -n specified
1267 unless ( $state ->{ globaloptions
}{- n
} )
1270 $log -> debug ( "SEND : u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode}" );
1271 print "u= $meta ->{mode},g= $meta ->{mode},o= $meta ->{mode} \n " ;
1273 # transmit file, format is single integer on a line by itself (file
1274 # size) followed by the file contents
1275 # TODO : we should copy files in blocks
1276 my $data = `cat $mergedFile ` ;
1277 $log -> debug ( "File size : " . length ( $data ));
1278 print length ( $data ) . " \n " ;
1290 my ( $cmd , $data ) = @_ ;
1294 #$log->debug("State : " . Dumper($state));
1296 $log -> info ( "req_ci : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1298 if ( $state ->{ method
} eq 'pserver' and $state ->{ user
} eq 'anonymous' )
1300 print "error 1 anonymous user cannot commit via pserver \n " ;
1305 if ( - e
$state ->{ CVSROOT
} . "/index" )
1307 $log -> warn ( "file 'index' already exists in the git repository" );
1308 print "error 1 Index already exists in git repo \n " ;
1313 # Grab a handle to the SQLite db and do any necessary updates
1314 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1317 # Remember where the head was at the beginning.
1318 my $parenthash = `git show-ref -s refs/heads/ $state ->{module}` ;
1320 if ( $parenthash !~ /^[0-9a-f]{40}$/ ) {
1321 print "error 1 pserver cannot find the current HEAD of module" ;
1326 setupWorkTree
( $parenthash );
1328 $log -> info ( "Lockless commit start, basing commit on ' $work ->{workDir}', index file is ' $work ->{index}'" );
1330 $log -> info ( "Created index ' $work ->{index}' for head $state ->{module} - exit status $?" );
1332 my @committedfiles = ();
1335 # foreach file specified on the command line ...
1336 foreach my $filename ( @
{ $state ->{ args
}} )
1338 my $committedfile = $filename ;
1339 $filename = filecleanup
( $filename );
1341 next unless ( exists $state ->{ entries
}{ $filename }{ modified_filename
} or not $state ->{ entries
}{ $filename }{ unchanged
} );
1343 my $meta = $updater -> getmeta ( $filename );
1344 $oldmeta { $filename } = $meta ;
1346 my $wrev = revparse
( $filename );
1348 my ( $filepart , $dirpart ) = filenamesplit
( $filename );
1350 # do a checkout of the file if it is part of this tree
1352 system ( 'git' , 'checkout-index' , '-f' , '-u' , $filename );
1354 die "Error running git-checkout-index -f -u $filename : $!" ;
1360 $rmflag = 1 if ( defined ( $wrev ) and $wrev < 0 );
1361 $addflag = 1 unless ( - e
$filename );
1363 # Do up to date checking
1364 unless ( $addflag or $wrev == $meta ->{ revision
} or ( $rmflag and - $wrev == $meta ->{ revision
} ) )
1366 # fail everything if an up to date check fails
1367 print "error 1 Up to date check failed for $filename \n " ;
1372 push @committedfiles , $committedfile ;
1373 $log -> info ( "Committing $filename " );
1375 system ( "mkdir" , "-p" , $dirpart ) unless ( - d
$dirpart );
1379 $log -> debug ( "rename $state ->{entries}{ $filename }{modified_filename} $filename " );
1380 rename $state ->{ entries
}{ $filename }{ modified_filename
}, $filename ;
1382 # Calculate modes to remove
1384 foreach ( qw
( r w x
) ) { $invmode .= $_ unless ( $state ->{ entries
}{ $filename }{ modified_mode
} =~ /$_/ ); }
1386 $log -> debug ( "chmod u+" . $state ->{ entries
}{ $filename }{ modified_mode
} . "-" . $invmode . " $filename " );
1387 system ( "chmod" , "u+" . $state ->{ entries
}{ $filename }{ modified_mode
} . "-" . $invmode , $filename );
1392 $log -> info ( "Removing file ' $filename '" );
1394 system ( "git" , "update-index" , "--remove" , $filename );
1398 $log -> info ( "Adding file ' $filename '" );
1399 system ( "git" , "update-index" , "--add" , $filename );
1401 $log -> info ( "Updating file ' $filename '" );
1402 system ( "git" , "update-index" , $filename );
1406 unless ( scalar ( @committedfiles ) > 0 )
1408 print "E No files to commit \n " ;
1414 my $treehash = `git write-tree` ;
1417 $log -> debug ( "Treehash : $treehash , Parenthash : $parenthash " );
1419 # write our commit message out if we have one ...
1420 my ( $msg_fh , $msg_filename ) = tempfile
( DIR
=> $TEMP_DIR );
1421 print $msg_fh $state ->{ opt
}{ m
}; # if ( exists ( $state->{opt}{m} ) );
1422 if ( defined ( $cfg ->{ gitcvs
}{ commitmsgannotation
} ) ) {
1423 if ( $cfg ->{ gitcvs
}{ commitmsgannotation
} !~ /^\s*$/ ) {
1424 print $msg_fh " \n\n " . $cfg ->{ gitcvs
}{ commitmsgannotation
}. " \n "
1427 print $msg_fh " \n\n via git-CVS emulator \n " ;
1431 my $commithash = `git commit-tree $treehash -p $parenthash < $msg_filename ` ;
1433 $log -> info ( "Commit hash : $commithash " );
1435 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1437 $log -> warn ( "Commit failed (Invalid commit hash)" );
1438 print "error 1 Commit failed (unknown reason) \n " ;
1443 ### Emulate git-receive-pack by running hooks/update
1444 my @hook = ( $ENV { GIT_DIR
}. 'hooks/update' , "refs/heads/ $state ->{module}" ,
1445 $parenthash , $commithash );
1447 unless ( system ( @hook ) == 0 )
1449 $log -> warn ( "Commit failed (update hook declined to update ref)" );
1450 print "error 1 Commit failed (update hook declined) \n " ;
1457 if ( system ( qw(git update-ref -m) , "cvsserver ci" ,
1458 "refs/heads/ $state ->{module}" , $commithash , $parenthash )) {
1459 $log -> warn ( "update-ref for $state ->{module} failed." );
1460 print "error 1 Cannot commit -- update first \n " ;
1465 ### Emulate git-receive-pack by running hooks/post-receive
1466 my $hook = $ENV { GIT_DIR
}. 'hooks/post-receive' ;
1468 open ( my $pipe , "| $hook " ) || die "can't fork $!" ;
1470 local $SIG { PIPE
} = sub { die 'pipe broke' };
1472 print $pipe " $parenthash $commithash refs/heads/ $state ->{module} \n " ;
1474 close $pipe || die "bad pipe: $! $?" ;
1479 ### Then hooks/post-update
1480 $hook = $ENV { GIT_DIR
}. 'hooks/post-update' ;
1482 system ( $hook , "refs/heads/ $state ->{module}" );
1485 # foreach file specified on the command line ...
1486 foreach my $filename ( @committedfiles )
1488 $filename = filecleanup
( $filename );
1490 my $meta = $updater -> getmeta ( $filename );
1491 unless ( defined $meta ->{ revision
}) {
1492 $meta ->{ revision
} = 1 ;
1495 my ( $filepart , $dirpart ) = filenamesplit
( $filename , 1 );
1497 $log -> debug ( "Checked-in $dirpart : $filename " );
1499 print "M $state ->{CVSROOT}/ $state ->{module}/ $filename ,v <-- $dirpart $filepart \n " ;
1500 if ( defined $meta ->{ filehash
} && $meta ->{ filehash
} eq "deleted" )
1502 print "M new revision: delete; previous revision: 1. $oldmeta { $filename }{revision} \n " ;
1503 print "Remove-entry $dirpart \n " ;
1504 print " $filename \n " ;
1506 if ( $meta ->{ revision
} == 1 ) {
1507 print "M initial revision: 1.1 \n " ;
1509 print "M new revision: 1. $meta ->{revision}; previous revision: 1. $oldmeta { $filename }{revision} \n " ;
1511 print "Checked-in $dirpart \n " ;
1512 print " $filename \n " ;
1513 my $kopts = kopts_from_path
( $filename , "sha1" , $meta ->{ filehash
});
1514 print "/ $filepart /1. $meta ->{revision}// $kopts / \n " ;
1524 my ( $cmd , $data ) = @_ ;
1528 $log -> info ( "req_status : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1529 #$log->debug("status state : " . Dumper($state));
1531 # Grab a handle to the SQLite db and do any necessary updates
1532 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1535 # if no files were specified, we need to work out what files we should be providing status on ...
1536 argsfromdir
( $updater );
1538 # foreach file specified on the command line ...
1539 foreach my $filename ( @
{ $state ->{ args
}} )
1541 $filename = filecleanup
( $filename );
1543 next if exists ( $state ->{ opt
}{ l
}) && index ( $filename , '/' , length ( $state ->{ prependdir
})) >= 0 ;
1545 my $meta = $updater -> getmeta ( $filename );
1546 my $oldmeta = $meta ;
1548 my $wrev = revparse
( $filename );
1550 # If the working copy is an old revision, lets get that version too for comparison.
1551 if ( defined ( $wrev ) and $wrev != $meta ->{ revision
} )
1553 $oldmeta = $updater -> getmeta ( $filename , $wrev );
1556 # TODO : All possible statuses aren't yet implemented
1558 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1559 $status = "Up-to-date" if ( defined ( $wrev ) and defined ( $meta ->{ revision
}) and $wrev == $meta ->{ revision
}
1561 ( ( $state ->{ entries
}{ $filename }{ unchanged
} and ( not defined ( $state ->{ entries
}{ $filename }{ conflict
} ) or $state ->{ entries
}{ $filename }{ conflict
} !~ /^\+=/ ) )
1562 or ( defined ( $state ->{ entries
}{ $filename }{ modified_hash
}) and $state ->{ entries
}{ $filename }{ modified_hash
} eq $meta ->{ filehash
} ) )
1565 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1566 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta ->{ revision
} ) and $meta ->{ revision
} > $wrev
1568 ( $state ->{ entries
}{ $filename }{ unchanged
}
1569 or ( defined ( $state ->{ entries
}{ $filename }{ modified_hash
}) and $state ->{ entries
}{ $filename }{ modified_hash
} eq $oldmeta ->{ filehash
} ) )
1572 # Need checkout if it exists in the repo but doesn't have a working copy
1573 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta ->{ revision
} ) );
1575 # Locally modified if working copy and repo copy have the same revision but there are local changes
1576 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined ( $meta ->{ revision
}) and $wrev == $meta ->{ revision
} and $state ->{ entries
}{ $filename }{ modified_filename
} );
1578 # Needs Merge if working copy revision is less than repo copy and there are local changes
1579 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta ->{ revision
} ) and $meta ->{ revision
} > $wrev and $state ->{ entries
}{ $filename }{ modified_filename
} );
1581 $status ||= "Locally Added" if ( defined ( $state ->{ entries
}{ $filename }{ revision
} ) and not defined ( $meta ->{ revision
} ) );
1582 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta ->{ revision
} ) and - $wrev == $meta ->{ revision
} );
1583 $status ||= "Unresolved Conflict" if ( defined ( $state ->{ entries
}{ $filename }{ conflict
} ) and $state ->{ entries
}{ $filename }{ conflict
} =~ /^\+=/ );
1584 $status ||= "File had conflicts on merge" if ( 0 );
1586 $status ||= "Unknown" ;
1588 my ( $filepart ) = filenamesplit
( $filename );
1590 print "M =================================================================== \n " ;
1591 print "M File: $filepart \t Status: $status \n " ;
1592 if ( defined ( $state ->{ entries
}{ $filename }{ revision
}) )
1594 print "M Working revision: \t " . $state ->{ entries
}{ $filename }{ revision
} . " \n " ;
1596 print "M Working revision: \t No entry for $filename \n " ;
1598 if ( defined ( $meta ->{ revision
}) )
1600 print "M Repository revision: \t 1." . $meta ->{ revision
} . " \t $state ->{CVSROOT}/ $state ->{module}/ $filename ,v \n " ;
1601 print "M Sticky Tag: \t\t (none) \n " ;
1602 print "M Sticky Date: \t\t (none) \n " ;
1603 print "M Sticky Options: \t\t (none) \n " ;
1605 print "M Repository revision: \t No revision control file \n " ;
1615 my ( $cmd , $data ) = @_ ;
1619 $log -> debug ( "req_diff : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1620 #$log->debug("status state : " . Dumper($state));
1622 my ( $revision1 , $revision2 );
1623 if ( defined ( $state ->{ opt
}{ r
} ) and ref $state ->{ opt
}{ r
} eq "ARRAY" )
1625 $revision1 = $state ->{ opt
}{ r
}[ 0 ];
1626 $revision2 = $state ->{ opt
}{ r
}[ 1 ];
1628 $revision1 = $state ->{ opt
}{ r
};
1631 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1632 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1634 $log -> debug ( "Diffing revisions " . ( defined ( $revision1 ) ?
$revision1 : "[NULL]" ) . " and " . ( defined ( $revision2 ) ?
$revision2 : "[NULL]" ) );
1636 # Grab a handle to the SQLite db and do any necessary updates
1637 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1640 # if no files were specified, we need to work out what files we should be providing status on ...
1641 argsfromdir
( $updater );
1643 # foreach file specified on the command line ...
1644 foreach my $filename ( @
{ $state ->{ args
}} )
1646 $filename = filecleanup
( $filename );
1648 my ( $fh , $file1 , $file2 , $meta1 , $meta2 , $filediff );
1650 my $wrev = revparse
( $filename );
1652 # We need _something_ to diff against
1653 next unless ( defined ( $wrev ) );
1655 # if we have a -r switch, use it
1656 if ( defined ( $revision1 ) )
1658 ( undef , $file1 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1659 $meta1 = $updater -> getmeta ( $filename , $revision1 );
1660 unless ( defined ( $meta1 ) and $meta1 ->{ filehash
} ne "deleted" )
1662 print "E File $filename at revision 1. $revision1 doesn't exist \n " ;
1665 transmitfile
( $meta1 ->{ filehash
}, { targetfile
=> $file1 });
1667 # otherwise we just use the working copy revision
1670 ( undef , $file1 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1671 $meta1 = $updater -> getmeta ( $filename , $wrev );
1672 transmitfile
( $meta1 ->{ filehash
}, { targetfile
=> $file1 });
1675 # if we have a second -r switch, use it too
1676 if ( defined ( $revision2 ) )
1678 ( undef , $file2 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1679 $meta2 = $updater -> getmeta ( $filename , $revision2 );
1681 unless ( defined ( $meta2 ) and $meta2 ->{ filehash
} ne "deleted" )
1683 print "E File $filename at revision 1. $revision2 doesn't exist \n " ;
1687 transmitfile
( $meta2 ->{ filehash
}, { targetfile
=> $file2 });
1689 # otherwise we just use the working copy
1692 $file2 = $state ->{ entries
}{ $filename }{ modified_filename
};
1695 # if we have been given -r, and we don't have a $file2 yet, lets get one
1696 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1698 ( undef , $file2 ) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
1699 $meta2 = $updater -> getmeta ( $filename , $wrev );
1700 transmitfile
( $meta2 ->{ filehash
}, { targetfile
=> $file2 });
1703 # We need to have retrieved something useful
1704 next unless ( defined ( $meta1 ) );
1706 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1707 next if ( not defined ( $meta2 ) and $wrev == $meta1 ->{ revision
}
1709 ( ( $state ->{ entries
}{ $filename }{ unchanged
} and ( not defined ( $state ->{ entries
}{ $filename }{ conflict
} ) or $state ->{ entries
}{ $filename }{ conflict
} !~ /^\+=/ ) )
1710 or ( defined ( $state ->{ entries
}{ $filename }{ modified_hash
}) and $state ->{ entries
}{ $filename }{ modified_hash
} eq $meta1 ->{ filehash
} ) )
1713 # Apparently we only show diffs for locally modified files
1714 next unless ( defined ( $meta2 ) or defined ( $state ->{ entries
}{ $filename }{ modified_filename
} ) );
1716 print "M Index: $filename \n " ;
1717 print "M =================================================================== \n " ;
1718 print "M RCS file: $state ->{CVSROOT}/ $state ->{module}/ $filename ,v \n " ;
1719 print "M retrieving revision 1. $meta1 ->{revision} \n " if ( defined ( $meta1 ) );
1720 print "M retrieving revision 1. $meta2 ->{revision} \n " if ( defined ( $meta2 ) );
1722 foreach my $opt ( keys %{ $state ->{ opt
}} )
1724 if ( ref $state ->{ opt
}{ $opt } eq "ARRAY" )
1726 foreach my $value ( @
{ $state ->{ opt
}{ $opt }} )
1728 print "- $opt $value " ;
1732 print " $state ->{opt}{ $opt } " if ( defined ( $state ->{ opt
}{ $opt } ) );
1735 print " $filename \n " ;
1737 $log -> info ( "Diffing $filename -r $meta1 ->{revision} -r " . ( $meta2 ->{ revision
} or "workingcopy" ));
1739 ( $fh , $filediff ) = tempfile
( DIR
=> $TEMP_DIR );
1741 if ( exists $state ->{ opt
}{ u
} )
1743 system ( "diff -u -L ' $filename revision 1. $meta1 ->{revision}' -L ' $filename " . ( defined ( $meta2 ->{ revision
}) ?
"revision 1. $meta2 ->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff " );
1745 system ( "diff $file1 $file2 > $filediff " );
1760 my ( $cmd , $data ) = @_ ;
1764 $log -> debug ( "req_log : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1765 #$log->debug("log state : " . Dumper($state));
1767 my ( $minrev , $maxrev );
1768 if ( defined ( $state ->{ opt
}{ r
} ) and $state ->{ opt
}{ r
} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1773 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1774 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1775 $minrev ++ if ( defined ( $minrev ) and $control eq "::" );
1778 # Grab a handle to the SQLite db and do any necessary updates
1779 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1782 # if no files were specified, we need to work out what files we should be providing status on ...
1783 argsfromdir
( $updater );
1785 # foreach file specified on the command line ...
1786 foreach my $filename ( @
{ $state ->{ args
}} )
1788 $filename = filecleanup
( $filename );
1790 my $headmeta = $updater -> getmeta ( $filename );
1792 my $revisions = $updater -> getlog ( $filename );
1793 my $totalrevisions = scalar ( @
$revisions );
1795 if ( defined ( $minrev ) )
1797 $log -> debug ( "Removing revisions less than $minrev " );
1798 while ( scalar ( @
$revisions ) > 0 and $revisions ->[- 1 ]{ revision
} < $minrev )
1803 if ( defined ( $maxrev ) )
1805 $log -> debug ( "Removing revisions greater than $maxrev " );
1806 while ( scalar ( @
$revisions ) > 0 and $revisions ->[ 0 ]{ revision
} > $maxrev )
1812 next unless ( scalar ( @
$revisions ) );
1815 print "M RCS file: $state ->{CVSROOT}/ $state ->{module}/ $filename ,v \n " ;
1816 print "M Working file: $filename \n " ;
1817 print "M head: 1. $headmeta ->{revision} \n " ;
1818 print "M branch: \n " ;
1819 print "M locks: strict \n " ;
1820 print "M access list: \n " ;
1821 print "M symbolic names: \n " ;
1822 print "M keyword substitution: kv \n " ;
1823 print "M total revisions: $totalrevisions ; \t selected revisions: " . scalar ( @
$revisions ) . " \n " ;
1824 print "M description: \n " ;
1826 foreach my $revision ( @
$revisions )
1828 print "M ---------------------------- \n " ;
1829 print "M revision 1. $revision ->{revision} \n " ;
1830 # reformat the date for log output
1831 $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 }) );
1832 $revision ->{ author
} = cvs_author
( $revision ->{ author
});
1833 print "M date: $revision ->{modified}; author: $revision ->{author}; state: " . ( $revision ->{ filehash
} eq "deleted" ?
"dead" : "Exp" ) . "; lines: +2 -3 \n " ;
1834 my $commitmessage = $updater -> commitmessage ( $revision ->{ commithash
});
1835 $commitmessage =~ s/^/M /mg ;
1836 print $commitmessage . " \n " ;
1838 print "M ============================================================================= \n " ;
1846 my ( $cmd , $data ) = @_ ;
1848 argsplit
( "annotate" );
1850 $log -> info ( "req_annotate : " . ( defined ( $data ) ?
$data : "[NULL]" ));
1851 #$log->debug("status state : " . Dumper($state));
1853 # Grab a handle to the SQLite db and do any necessary updates
1854 my $updater = GITCVS
:: updater
-> new ( $state ->{ CVSROOT
}, $state ->{ module
}, $log );
1857 # if no files were specified, we need to work out what files we should be providing annotate on ...
1858 argsfromdir
( $updater );
1860 # we'll need a temporary checkout dir
1863 $log -> info ( "Temp checkoutdir creation successful, basing annotate session work on ' $work ->{workDir}', index file is ' $ENV {GIT_INDEX_FILE}'" );
1865 # foreach file specified on the command line ...
1866 foreach my $filename ( @
{ $state ->{ args
}} )
1868 $filename = filecleanup
( $filename );
1870 my $meta = $updater -> getmeta ( $filename );
1872 next unless ( $meta ->{ revision
} );
1874 # get all the commits that this file was in
1875 # in dense format -- aka skip dead revisions
1876 my $revisions = $updater -> gethistorydense ( $filename );
1877 my $lastseenin = $revisions ->[ 0 ][ 2 ];
1879 # populate the temporary index based on the latest commit were we saw
1880 # the file -- but do it cheaply without checking out any files
1881 # TODO: if we got a revision from the client, use that instead
1882 # to look up the commithash in sqlite (still good to default to
1883 # the current head as we do now)
1884 system ( "git" , "read-tree" , $lastseenin );
1887 print "E error running git-read-tree $lastseenin $ENV {GIT_INDEX_FILE} $! \n " ;
1890 $log -> info ( "Created index ' $ENV {GIT_INDEX_FILE}' with commit $lastseenin - exit status $?" );
1892 # do a checkout of the file
1893 system ( 'git' , 'checkout-index' , '-f' , '-u' , $filename );
1895 print "E error running git-checkout-index -f -u $filename : $! \n " ;
1899 $log -> info ( "Annotate $filename " );
1901 # Prepare a file with the commits from the linearized
1902 # history that annotate should know about. This prevents
1903 # git-jsannotate telling us about commits we are hiding
1906 my $a_hints = " $work ->{workDir}/.annotate_hints" ;
1907 if (! open ( ANNOTATEHINTS
, '>' , $a_hints )) {
1908 print "E failed to open ' $a_hints ' for writing: $! \n " ;
1911 for ( my $i = 0 ; $i < @
$revisions ; $i ++)
1913 print ANNOTATEHINTS
$revisions ->[ $i ][ 2 ];
1914 if ( $i + 1 < @
$revisions ) { # have we got a parent?
1915 print ANNOTATEHINTS
' ' . $revisions ->[ $i + 1 ][ 2 ];
1917 print ANNOTATEHINTS
" \n " ;
1920 print ANNOTATEHINTS
" \n " ;
1922 or ( print "E failed to write $a_hints : $! \n " ), return ;
1924 my @cmd = ( qw(git annotate -l -S) , $a_hints , $filename );
1925 if (! open ( ANNOTATE
, "-|" , @cmd )) {
1926 print "E error invoking " . join ( ' ' , @cmd ) . ": $! \n " ;
1930 print "E Annotations for $filename \n " ;
1931 print "E *************** \n " ;
1932 while ( < ANNOTATE
> )
1934 if ( m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i )
1936 my $commithash = $1 ;
1938 unless ( defined ( $metadata ->{ $commithash } ) )
1940 $metadata ->{ $commithash } = $updater -> getmeta ( $filename , $commithash );
1941 $metadata ->{ $commithash }{ author
} = cvs_author
( $metadata ->{ $commithash }{ author
});
1942 $metadata ->{ $commithash }{ modified
} = sprintf ( " %02d - %s - %02d " , $1 , $2 , $3 ) if ( $metadata ->{ $commithash }{ modified
} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1944 printf ( "M 1.%-5d (%-8s %10s ): %s \n " ,
1945 $metadata ->{ $commithash }{ revision
},
1946 $metadata ->{ $commithash }{ author
},
1947 $metadata ->{ $commithash }{ modified
},
1951 $log -> warn ( "Error in annotate output! LINE: $_ " );
1952 print "E Annotate error \n " ;
1959 # done; get out of the tempdir
1966 # This method takes the state->{arguments} array and produces two new arrays.
1967 # The first is $state->{args} which is everything before the '--' argument, and
1968 # the second is $state->{files} which is everything after it.
1971 $state ->{ args
} = [];
1972 $state ->{ files
} = [];
1975 return unless ( defined ( $state ->{ arguments
}) and ref $state ->{ arguments
} eq "ARRAY" );
1979 if ( defined ( $type ) )
1982 $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" );
1983 $opt = { v
=> 0 , l
=> 0 , R
=> 0 } if ( $type eq "status" );
1984 $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" );
1985 $opt = { l
=> 0 , R
=> 0 , k
=> 1 , D
=> 1 , D
=> 1 , r
=> 2 } if ( $type eq "diff" );
1986 $opt = { c
=> 0 , R
=> 0 , l
=> 0 , f
=> 0 , F
=> 1 , m
=> 1 , r
=> 1 } if ( $type eq "ci" );
1987 $opt = { k
=> 1 , m
=> 1 } if ( $type eq "add" );
1988 $opt = { f
=> 0 , l
=> 0 , R
=> 0 } if ( $type eq "remove" );
1989 $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" );
1992 while ( scalar ( @
{ $state ->{ arguments
}} ) > 0 )
1994 my $arg = shift @
{ $state ->{ arguments
}};
1996 next if ( $arg eq "--" );
1997 next unless ( $arg =~ /\S/ );
1999 # if the argument looks like a switch
2000 if ( $arg =~ /^-(\w)(.*)/ )
2002 # if it's a switch that takes an argument
2005 # If this switch has already been provided
2006 if ( $opt ->{ $1 } > 1 and exists ( $state ->{ opt
}{ $1 } ) )
2008 $state ->{ opt
}{ $1 } = [ $state ->{ opt
}{ $1 } ];
2009 if ( length ( $2 ) > 0 )
2011 push @
{ $state ->{ opt
}{ $1 }}, $2 ;
2013 push @
{ $state ->{ opt
}{ $1 }}, shift @
{ $state ->{ arguments
}};
2016 # if there's extra data in the arg, use that as the argument for the switch
2017 if ( length ( $2 ) > 0 )
2019 $state ->{ opt
}{ $1 } = $2 ;
2021 $state ->{ opt
}{ $1 } = shift @
{ $state ->{ arguments
}};
2025 $state ->{ opt
}{ $1 } = undef ;
2030 push @
{ $state ->{ args
}}, $arg ;
2038 foreach my $value ( @
{ $state ->{ arguments
}} )
2040 if ( $value eq "--" )
2045 push @
{ $state ->{ args
}}, $value if ( $mode == 0 );
2046 push @
{ $state ->{ files
}}, $value if ( $mode == 1 );
2051 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
2054 my $updater = shift ;
2056 $state ->{ args
} = [] if ( scalar ( @
{ $state ->{ args
}}) == 1 and $state ->{ args
}[ 0 ] eq "." );
2058 return if ( scalar ( @
{ $state ->{ args
}} ) > 1 );
2060 my @gethead = @
{ $updater -> gethead };
2063 foreach my $file ( keys %{ $state ->{ entries
}}) {
2064 if ( exists $state ->{ entries
}{ $file }{ revision
} &&
2065 $state ->{ entries
}{ $file }{ revision
} == 0 )
2067 push @gethead , { name
=> $file , filehash
=> 'added' };
2071 if ( scalar ( @
{ $state ->{ args
}}) == 1 )
2073 my $arg = $state ->{ args
}[ 0 ];
2074 $arg .= $state ->{ prependdir
} if ( defined ( $state ->{ prependdir
} ) );
2076 $log -> info ( "Only one arg specified, checking for directory expansion on ' $arg '" );
2078 foreach my $file ( @gethead )
2080 next if ( $file ->{ filehash
} eq "deleted" and not defined ( $state ->{ entries
}{ $file ->{ name
}} ) );
2081 next unless ( $file ->{ name
} =~ /^$arg\/ / or $file ->{ name
} eq $arg );
2082 push @
{ $state ->{ args
}}, $file ->{ name
};
2085 shift @
{ $state ->{ args
}} if ( scalar ( @
{ $state ->{ args
}}) > 1 );
2087 $log -> info ( "Only one arg specified, populating file list automatically" );
2089 $state ->{ args
} = [];
2091 foreach my $file ( @gethead )
2093 next if ( $file ->{ filehash
} eq "deleted" and not defined ( $state ->{ entries
}{ $file ->{ name
}} ) );
2094 next unless ( $file ->{ name
} =~ s/^$state->{prependdir}// );
2095 push @
{ $state ->{ args
}}, $file ->{ name
};
2100 # This method cleans up the $state variable after a command that uses arguments has run
2103 $state ->{ files
} = [];
2104 $state ->{ args
} = [];
2105 $state ->{ arguments
} = [];
2106 $state ->{ entries
} = {};
2111 my $filename = shift ;
2113 return undef unless ( defined ( $state ->{ entries
}{ $filename }{ revision
} ) );
2115 return $1 if ( $state ->{ entries
}{ $filename }{ revision
} =~ /^1\.(\d+)/ );
2116 return - $1 if ( $state ->{ entries
}{ $filename }{ revision
} =~ /^-1\.(\d+)/ );
2121 # This method takes a file hash and does a CVS "file transfer". Its
2122 # exact behaviour depends on a second, optional hash table argument:
2123 # - If $options->{targetfile}, dump the contents to that file;
2124 # - If $options->{print}, use M/MT to transmit the contents one line
2126 # - Otherwise, transmit the size of the file, followed by the file
2130 my $filehash = shift ;
2131 my $options = shift ;
2133 if ( defined ( $filehash ) and $filehash eq "deleted" )
2135 $log -> warn ( "filehash is 'deleted'" );
2139 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2141 my $type = `git cat-file -t $filehash ` ;
2144 die ( "Invalid type ' $type ' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2146 my $size = `git cat-file -s $filehash ` ;
2149 $log -> debug ( "transmitfile( $filehash ) size= $size , type= $type " );
2151 if ( open my $fh , '-|' , "git" , "cat-file" , "blob" , $filehash )
2153 if ( defined ( $options ->{ targetfile
} ) )
2155 my $targetfile = $options ->{ targetfile
};
2156 open NEWFILE
, ">" , $targetfile or die ( "Couldn't open ' $targetfile ' for writing : $!" );
2157 print NEWFILE
$_ while ( < $fh > );
2158 close NEWFILE
or die ( "Failed to write ' $targetfile ': $!" );
2159 } elsif ( defined ( $options ->{ print } ) && $options ->{ print } ) {
2164 print 'MT text ' , $_ , " \n " ;
2169 print while ( < $fh > );
2171 close $fh or die ( "Couldn't close filehandle for transmitfile(): $!" );
2173 die ( "Couldn't execute git-cat-file" );
2177 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2178 # refers to the directory portion and the file portion of the filename
2182 my $filename = shift ;
2183 my $fixforlocaldir = shift ;
2185 my ( $filepart , $dirpart ) = ( $filename , "." );
2186 ( $filepart , $dirpart ) = ( $2 , $1 ) if ( $filename =~ /(.*)\/ (.*)/ );
2189 if ( $fixforlocaldir )
2191 $dirpart =~ s/^$state->{prependdir}// ;
2194 return ( $filepart , $dirpart );
2199 my $filename = shift ;
2201 return undef unless ( defined ( $filename ));
2202 if ( $filename =~ /^\/ / )
2204 print "E absolute filenames ' $filename ' not supported by server \n " ;
2208 $filename =~ s/^\.\// / g
;
2209 $filename = $state ->{ prependdir
} . $filename ;
2215 if ( ! defined ( $state ->{ CVSROOT
}) )
2217 print "error 1 CVSROOT not specified \n " ;
2221 if ( $ENV { GIT_DIR
} ne ( $state ->{ CVSROOT
} . '/' ) )
2223 print "error 1 Internally inconsistent CVSROOT \n " ;
2229 # Setup working directory in a work tree with the requested version
2230 # loaded in the index.
2237 if ( ( defined ( $work ->{ state }) && $work ->{ state } != 1 ) ||
2238 defined ( $work ->{ tmpDir
}) )
2240 $log -> warn ( "Bad work tree state management" );
2241 print "error 1 Internal setup multiple work trees without cleanup \n " ;
2246 $work ->{ workDir
} = tempdir
( DIR
=> $TEMP_DIR );
2248 if ( ! defined ( $work ->{ index }) )
2250 ( undef , $work ->{ index }) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
2253 chdir $work ->{ workDir
} or
2254 die "Unable to chdir to $work ->{workDir} \n " ;
2256 $log -> info ( "Setting up GIT_WORK_TREE as '.' in ' $work ->{workDir}', index file is ' $work ->{index}'" );
2258 $ENV { GIT_WORK_TREE
} = "." ;
2259 $ENV { GIT_INDEX_FILE
} = $work ->{ index };
2264 system ( "git" , "read-tree" , $ver );
2267 $log -> warn ( "Error running git-read-tree" );
2268 die "Error running git-read-tree $ver in $work ->{workDir} $! \n " ;
2271 # else # req_annotate reads tree for each file
2274 # Ensure current directory is in some kind of working directory,
2275 # with a recent version loaded in the index.
2278 if ( defined ( $work ->{ tmpDir
}) )
2280 $log -> warn ( "Bad work tree state management [ensureWorkTree()]" );
2281 print "error 1 Internal setup multiple dirs without cleanup \n " ;
2285 if ( $work ->{ state } )
2292 if ( ! defined ( $work ->{ emptyDir
}) )
2294 $work ->{ emptyDir
} = tempdir
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
2296 chdir $work ->{ emptyDir
} or
2297 die "Unable to chdir to $work ->{emptyDir} \n " ;
2299 my $ver = `git show-ref -s refs/heads/ $state ->{module}` ;
2301 if ( $ver !~ /^[0-9a-f]{40}$/ )
2303 $log -> warn ( "Error from git show-ref -s refs/head $state ->{module}" );
2304 print "error 1 cannot find the current HEAD of module" ;
2309 if ( ! defined ( $work ->{ index }) )
2311 ( undef , $work ->{ index }) = tempfile
( DIR
=> $TEMP_DIR , OPEN
=> 0 );
2314 $ENV { GIT_WORK_TREE
} = "." ;
2315 $ENV { GIT_INDEX_FILE
} = $work ->{ index };
2318 system ( "git" , "read-tree" , $ver );
2321 die "Error running git-read-tree $ver $! \n " ;
2325 # Cleanup working directory that is not needed any longer.
2328 if ( ! $work ->{ state } )
2333 chdir "/" or die "Unable to chdir '/' \n " ;
2335 if ( defined ( $work ->{ workDir
}) )
2337 rmtree
( $work ->{ workDir
} );
2338 undef $work ->{ workDir
};
2340 undef $work ->{ state };
2343 # Setup a temporary directory (not a working tree), typically for
2344 # merging dirty state as in req_update.
2347 $work ->{ tmpDir
} = tempdir
( DIR
=> $TEMP_DIR );
2348 chdir $work ->{ tmpDir
} or die "Unable to chdir $work ->{tmpDir} \n " ;
2350 return $work ->{ tmpDir
};
2353 # Clean up a previously setupTmpDir. Restore previous work tree if
2357 if ( ! defined ( $work ->{ tmpDir
}) )
2359 $log -> warn ( "cleanup tmpdir that has not been setup" );
2360 die "Cleanup tmpDir that has not been setup \n " ;
2362 if ( defined ( $work ->{ state }) )
2364 if ( $work ->{ state } == 1 )
2366 chdir $work ->{ emptyDir
} or
2367 die "Unable to chdir to $work ->{emptyDir} \n " ;
2369 elsif ( $work ->{ state } == 2 )
2371 chdir $work ->{ workDir
} or
2372 die "Unable to chdir to $work ->{emptyDir} \n " ;
2376 $log -> warn ( "Inconsistent work dir state" );
2377 die "Inconsistent work dir state \n " ;
2382 chdir "/" or die "Unable to chdir '/' \n " ;
2386 # Given a path, this function returns a string containing the kopts
2387 # that should go into that path's Entries line. For example, a binary
2388 # file should get -kb.
2391 my ( $path , $srcType , $name ) = @_ ;
2393 if ( defined ( $cfg ->{ gitcvs
}{ usecrlfattr
} ) and
2394 $cfg ->{ gitcvs
}{ usecrlfattr
} =~ /\s*(1|true|yes)\s*$/i )
2396 my ( $val ) = check_attr
( "crlf" , $path );
2397 if ( $val eq "set" )
2401 elsif ( $val eq "unset" )
2407 $log -> info ( "Unrecognized check_attr crlf $path : $val " );
2411 if ( defined ( $cfg ->{ gitcvs
}{ allbinary
} ) )
2413 if ( ( $cfg ->{ gitcvs
}{ allbinary
} =~ /^\s*(1|true|yes)\s*$/i ) )
2417 elsif ( ( $cfg ->{ gitcvs
}{ allbinary
} =~ /^\s*guess\s*$/i ) )
2419 if ( $srcType eq "sha1Or-k" &&
2422 my ( $ret )= $state ->{ entries
}{ $path }{ options
};
2423 if ( ! defined ( $ret ) )
2425 $ret = $state ->{ opt
}{ k
};
2435 if ( ! ( $ret =~ /^(|-kb|-kkv|-kkvl|-kk|-ko|-kv)$/ ) )
2437 print "E Bad -k option \n " ;
2438 $log -> warn ( "Bad -k option: $ret " );
2439 die "Error: Bad -k option: $ret \n " ;
2446 if ( is_binary
( $srcType , $name ) )
2448 $log -> debug ( "... as binary" );
2453 $log -> debug ( "... as text" );
2458 # Return "" to give no special treatment to any path
2464 my ( $attr , $path ) = @_ ;
2466 if ( open my $fh , '-|' , "git" , "check-attr" , $attr , "--" , $path )
2470 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/ ;
2479 # This should have the same heuristics as convert.c:is_binary() and related.
2480 # Note that the bare CR test is done by callers in convert.c.
2483 my ( $srcType , $name ) = @_ ;
2484 $log -> debug ( "is_binary( $srcType , $name )" );
2486 # Minimize amount of interpreted code run in the inner per-character
2487 # loop for large files, by totalling each character value and
2488 # then analyzing the totals.
2491 for ( $i = 0 ; $i < 256 ; $i ++)
2496 my $fh = open_blob_or_die
( $srcType , $name );
2498 while ( defined ( $line =< $fh >) )
2500 # Any '\0' and bare CR are considered binary.
2501 if ( $line =~ /\0|(\r[^\n])/ )
2507 # Count up each character in the line:
2508 my $len = length ( $line );
2509 for ( $i = 0 ; $i < $len ; $i ++)
2511 $counts [ ord ( substr ( $line , $i , 1 ))]++;
2516 # Don't count CR and LF as either printable/nonprintable
2517 $counts [ ord ( " \n " )]= 0 ;
2518 $counts [ ord ( " \r " )]= 0 ;
2520 # Categorize individual character count into printable and nonprintable:
2523 for ( $i = 0 ; $i < 256 ; $i ++)
2531 $nonprintable += $counts [ $i ];
2533 elsif ( $i == 127 ) # DEL
2535 $nonprintable += $counts [ $i ];
2539 $printable += $counts [ $i ];
2543 return ( $printable >> 7 ) < $nonprintable ;
2546 # Returns open file handle. Possible invocations:
2547 # - open_blob_or_die("file",$filename);
2548 # - open_blob_or_die("sha1",$filehash);
2549 sub open_blob_or_die
2551 my ( $srcType , $name ) = @_ ;
2553 if ( $srcType eq "file" )
2555 if ( ! open $fh , "<" , $name )
2557 $log -> warn ( "Unable to open file $name : $!" );
2558 die "Unable to open file $name : $! \n " ;
2561 elsif ( $srcType eq "sha1" || $srcType eq "sha1Or-k" )
2563 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
2565 $log -> warn ( "Need filehash" );
2566 die "Need filehash \n " ;
2569 my $type = `git cat-file -t $name ` ;
2572 unless ( defined ( $type ) and $type eq "blob" )
2574 $log -> warn ( "Invalid type ' $type ' for ' $name '" );
2575 die ( "Invalid type ' $type ' (expected 'blob')" )
2578 my $size = `git cat-file -s $name ` ;
2581 $log -> debug ( "open_blob_or_die( $name ) size= $size , type= $type " );
2583 unless ( open $fh , '-|' , "git" , "cat-file" , "blob" , $name )
2585 $log -> warn ( "Unable to open sha1 $name " );
2586 die "Unable to open sha1 $name \n " ;
2591 $log -> warn ( "Unknown type of blob source: $srcType " );
2592 die "Unknown type of blob source: $srcType \n " ;
2597 # Generate a CVS author name from Git author information, by taking the local
2598 # part of the email address and replacing characters not in the Portable
2599 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
2600 # Login names are Unix login names, which should be restricted to this
2604 my $author_line = shift ;
2605 ( my $author ) = $author_line =~ /<([^@>]*)/ ;
2607 $author =~ s/[^-a-zA-Z0-9_.]/_/g ;
2616 # This table is from src/scramble.c in the CVS source
2618 0 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 ,
2619 16 , 17 , 18 , 19 , 20 , 21 , 22 , 23 , 24 , 25 , 26 , 27 , 28 , 29 , 30 , 31 ,
2620 114 , 120 , 53 , 79 , 96 , 109 , 72 , 108 , 70 , 64 , 76 , 67 , 116 , 74 , 68 , 87 ,
2621 111 , 52 , 75 , 119 , 49 , 34 , 82 , 81 , 95 , 65 , 112 , 86 , 118 , 110 , 122 , 105 ,
2622 41 , 57 , 83 , 43 , 46 , 102 , 40 , 89 , 38 , 103 , 45 , 50 , 42 , 123 , 91 , 35 ,
2623 125 , 55 , 54 , 66 , 124 , 126 , 59 , 47 , 92 , 71 , 115 , 78 , 88 , 107 , 106 , 56 ,
2624 36 , 121 , 117 , 104 , 101 , 100 , 69 , 73 , 99 , 63 , 94 , 93 , 39 , 37 , 61 , 48 ,
2625 58 , 113 , 32 , 90 , 44 , 98 , 60 , 51 , 33 , 97 , 62 , 77 , 84 , 80 , 85 , 223 ,
2626 225 , 216 , 187 , 166 , 229 , 189 , 222 , 188 , 141 , 249 , 148 , 200 , 184 , 136 , 248 , 190 ,
2627 199 , 170 , 181 , 204 , 138 , 232 , 218 , 183 , 255 , 234 , 220 , 247 , 213 , 203 , 226 , 193 ,
2628 174 , 172 , 228 , 252 , 217 , 201 , 131 , 230 , 197 , 211 , 145 , 238 , 161 , 179 , 160 , 212 ,
2629 207 , 221 , 254 , 173 , 202 , 146 , 224 , 151 , 140 , 196 , 205 , 130 , 135 , 133 , 143 , 246 ,
2630 192 , 159 , 244 , 239 , 185 , 168 , 215 , 144 , 139 , 165 , 180 , 157 , 147 , 186 , 214 , 176 ,
2631 227 , 231 , 219 , 169 , 175 , 156 , 206 , 198 , 129 , 164 , 150 , 210 , 154 , 177 , 134 , 127 ,
2632 182 , 128 , 158 , 208 , 162 , 132 , 167 , 209 , 149 , 241 , 153 , 251 , 237 , 236 , 171 , 195 ,
2633 243 , 233 , 253 , 240 , 194 , 250 , 191 , 155 , 142 , 137 , 245 , 235 , 163 , 242 , 178 , 152
2637 # This should never happen, the same password format (A) bas been
2638 # used by CVS since the beginning of time
2639 die "invalid password format $1 " unless substr ( $str , 0 , 1 ) eq 'A' ;
2641 my @str = unpack "C*" , substr ( $str , 1 );
2642 my $ret = join '' , map { chr $SHIFTS [ $_ ] } @str ;
2647 package GITCVS
:: log ;
2650 #### Copyright The Open University UK - 2006.
2652 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2653 #### Martin Langhoff <martin@catalyst.net.nz>
2666 This module provides very crude logging with a similar interface to
2675 Creates a new log object, optionally you can specify a filename here to
2676 indicate the file to log to. If no log file is specified, you can specify one
2677 later with method setfile, or indicate you no longer want logging with method
2680 Until one of these methods is called, all log calls will buffer messages ready
2687 my $filename = shift ;
2691 bless $self , $class ;
2693 if ( defined ( $filename ) )
2695 open $self ->{ fh
}, ">>" , $filename or die ( "Couldn't open ' $filename ' for writing : $!" );
2703 This methods takes a filename, and attempts to open that file as the log file.
2704 If successful, all buffered data is written out to the file, and any further
2705 logging is written directly to the file.
2711 my $filename = shift ;
2713 if ( defined ( $filename ) )
2715 open $self ->{ fh
}, ">>" , $filename or die ( "Couldn't open ' $filename ' for writing : $!" );
2718 return unless ( defined ( $self ->{ buffer
} ) and ref $self ->{ buffer
} eq "ARRAY" );
2720 while ( my $line = shift @
{ $self ->{ buffer
}} )
2722 print { $self ->{ fh
}} $line ;
2728 This method indicates no logging is going to be used. It flushes any entries in
2729 the internal buffer, and sets a flag to ensure no further data is put there.
2738 return unless ( defined ( $self ->{ buffer
} ) and ref $self ->{ buffer
} eq "ARRAY" );
2740 $self ->{ buffer
} = [];
2745 Internal method. Returns true if the log file is open, false otherwise.
2752 return 1 if ( defined ( $self ->{ fh
} ) and ref $self ->{ fh
} eq "GLOB" );
2756 =head2 debug info warn fatal
2758 These four methods are wrappers to _log. They provide the actual interface for
2762 sub debug
{ my $self = shift ; $self -> _log ( "debug" , @_ ); }
2763 sub info
{ my $self = shift ; $self -> _log ( "info" , @_ ); }
2764 sub warn { my $self = shift ; $self -> _log ( "warn" , @_ ); }
2765 sub fatal
{ my $self = shift ; $self -> _log ( "fatal" , @_ ); }
2769 This is an internal method called by the logging functions. It generates a
2770 timestamp and pushes the logged line either to file, or internal buffer.
2778 return if ( $self ->{ nolog
} );
2780 my @time = localtime ;
2781 my $timestring = sprintf ( " %4d - %02d - %02d %02d : %02d : %02d : %-5s" ,
2791 if ( $self -> _logopen )
2793 print { $self ->{ fh
}} $timestring . " - " . join ( " " , @_ ) . " \n " ;
2795 push @
{ $self ->{ buffer
}}, $timestring . " - " . join ( " " , @_ ) . " \n " ;
2801 This method simply closes the file handle if one is open
2808 if ( $self -> _logopen )
2814 package GITCVS
:: updater
;
2817 #### Copyright The Open University UK - 2006.
2819 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
2820 #### Martin Langhoff <martin@catalyst.net.nz>
2842 die "Need to specify a git repository" unless ( defined ( $config ) and - d
$config );
2843 die "Need to specify a module" unless ( defined ( $module ) );
2845 $class = ref ( $class ) || $class ;
2849 bless $self , $class ;
2851 $self ->{ valid_tables
} = { 'revision' => 1 ,
2852 'revision_ix1' => 1 ,
2853 'revision_ix2' => 1 ,
2859 $self ->{ module
} = $module ;
2860 $self ->{ git_path
} = $config . "/" ;
2862 $self ->{ log } = $log ;
2864 die "Git repo ' $self ->{git_path}' doesn't exist" unless ( - d
$self ->{ git_path
} );
2866 $self ->{ dbdriver
} = $cfg ->{ gitcvs
}{ $state ->{ method
}}{ dbdriver
} ||
2867 $cfg ->{ gitcvs
}{ dbdriver
} || "SQLite" ;
2868 $self ->{ dbname
} = $cfg ->{ gitcvs
}{ $state ->{ method
}}{ dbname
} ||
2869 $cfg ->{ gitcvs
}{ dbname
} || " %Ggitcvs . %m .sqlite" ;
2870 $self ->{ dbuser
} = $cfg ->{ gitcvs
}{ $state ->{ method
}}{ dbuser
} ||
2871 $cfg ->{ gitcvs
}{ dbuser
} || "" ;
2872 $self ->{ dbpass
} = $cfg ->{ gitcvs
}{ $state ->{ method
}}{ dbpass
} ||
2873 $cfg ->{ gitcvs
}{ dbpass
} || "" ;
2874 $self ->{ dbtablenameprefix
} = $cfg ->{ gitcvs
}{ $state ->{ method
}}{ dbtablenameprefix
} ||
2875 $cfg ->{ gitcvs
}{ dbtablenameprefix
} || "" ;
2876 my %mapping = ( m
=> $module ,
2877 a
=> $state ->{ method
},
2878 u
=> getlogin || getpwuid ($<) || $<,
2879 G
=> $self ->{ git_path
},
2880 g
=> mangle_dirname
( $self ->{ git_path
}),
2882 $self ->{ dbname
} =~ s/%([mauGg])/$mapping{$1}/eg ;
2883 $self ->{ dbuser
} =~ s/%([mauGg])/$mapping{$1}/eg ;
2884 $self ->{ dbtablenameprefix
} =~ s/%([mauGg])/$mapping{$1}/eg ;
2885 $self ->{ dbtablenameprefix
} = mangle_tablename
( $self ->{ dbtablenameprefix
});
2887 die "Invalid char ':' in dbdriver" if $self ->{ dbdriver
} =~ /:/ ;
2888 die "Invalid char ';' in dbname" if $self ->{ dbname
} =~ /;/ ;
2889 $self ->{ dbh
} = DBI
-> connect ( "dbi: $self ->{dbdriver}:dbname= $self ->{dbname}" ,
2892 die "Error connecting to database \n " unless defined $self ->{ dbh
};
2894 $self ->{ tables
} = {};
2895 foreach my $table ( keys %{ $self ->{ dbh
}-> table_info ( undef , undef , undef , 'TABLE' )-> fetchall_hashref ( 'TABLE_NAME' )} )
2897 $self ->{ tables
}{ $table } = 1 ;
2900 # Construct the revision table if required
2901 unless ( $self ->{ tables
}{ $self -> tablename ( "revision" )} )
2903 my $tablename = $self -> tablename ( "revision" );
2904 my $ix1name = $self -> tablename ( "revision_ix1" );
2905 my $ix2name = $self -> tablename ( "revision_ix2" );
2907 CREATE TABLE $tablename (
2909 revision INTEGER NOT NULL,
2910 filehash TEXT NOT NULL,
2911 commithash TEXT NOT NULL,
2912 author TEXT NOT NULL,
2913 modified TEXT NOT NULL,
2918 CREATE INDEX $ix1name
2919 ON $tablename (name,revision)
2922 CREATE INDEX $ix2name
2923 ON $tablename (name,commithash)
2927 # Construct the head table if required
2928 unless ( $self ->{ tables
}{ $self -> tablename ( "head" )} )
2930 my $tablename = $self -> tablename ( "head" );
2931 my $ix1name = $self -> tablename ( "head_ix1" );
2933 CREATE TABLE $tablename (
2935 revision INTEGER NOT NULL,
2936 filehash TEXT NOT NULL,
2937 commithash TEXT NOT NULL,
2938 author TEXT NOT NULL,
2939 modified TEXT NOT NULL,
2944 CREATE INDEX $ix1name
2945 ON $tablename (name)
2949 # Construct the properties table if required
2950 unless ( $self ->{ tables
}{ $self -> tablename ( "properties" )} )
2952 my $tablename = $self -> tablename ( "properties" );
2954 CREATE TABLE $tablename (
2955 key TEXT NOT NULL PRIMARY KEY,
2961 # Construct the commitmsgs table if required
2962 unless ( $self ->{ tables
}{ $self -> tablename ( "commitmsgs" )} )
2964 my $tablename = $self -> tablename ( "commitmsgs" );
2966 CREATE TABLE $tablename (
2967 key TEXT NOT NULL PRIMARY KEY,
2984 if ( exists $self ->{ valid_tables
}{ $name }) {
2985 return $self ->{ dbtablenameprefix
} . $name ;
2998 # first lets get the commit list
2999 $ENV { GIT_DIR
} = $self ->{ git_path
};
3001 my $commitsha1 = `git rev-parse $self ->{module}` ;
3004 my $commitinfo = `git cat-file commit $self ->{module} 2>&1` ;
3005 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3007 die ( "Invalid module ' $self ->{module}'" );
3012 my $lastcommit = $self -> _get_prop ( "last_commit" );
3014 if ( defined $lastcommit && $lastcommit eq $commitsha1 ) { # up-to-date
3018 # Start exclusive lock here...
3019 $self ->{ dbh
}-> begin_work () or die "Cannot lock database for BEGIN" ;
3021 # TODO: log processing is memory bound
3022 # if we can parse into a 2nd file that is in reverse order
3023 # we can probably do something really efficient
3024 my @git_log_params = ( '--pretty' , '--parents' , '--topo-order' );
3026 if ( defined $lastcommit ) {
3027 push @git_log_params , " $lastcommit .. $self ->{module}" ;
3029 push @git_log_params , $self ->{ module
};
3031 # git-rev-list is the backend / plumbing version of git-log
3032 open ( GITLOG
, '-|' , 'git' , 'rev-list' , @git_log_params ) or die "Cannot call git-rev-list: $!" ;
3041 if ( m/^commit\s+(.*)$/ ) {
3042 # on ^commit lines put the just seen commit in the stack
3043 # and prime things for the next one
3046 unshift @commits , \
%copy ;
3049 my @parents = split ( m/\s+/ , $1 );
3050 $commit { hash
} = shift @parents ;
3051 $commit { parents
} = \
@parents ;
3052 } elsif ( m/^(\w+?):\s+(.*)$/ && ! exists ( $commit { message
})) {
3053 # on rfc822-like lines seen before we see any message,
3054 # lowercase the entry and put it in the hash as key-value
3055 $commit { lc ( $1 )} = $2 ;
3057 # message lines - skip initial empty line
3058 # and trim whitespace
3059 if (! exists ( $commit { message
}) && m/^\s*$/ ) {
3060 # define it to mark the end of headers
3061 $commit { message
} = '' ;
3064 s/^\s+// ; s/\s+$// ; # trim ws
3065 $commit { message
} .= $_ . " \n " ;
3070 unshift @commits , \
%commit if ( keys %commit );
3072 # Now all the commits are in the @commits bucket
3073 # ordered by time DESC. for each commit that needs processing,
3074 # determine whether it's following the last head we've seen or if
3075 # it's on its own branch, grab a file list, and add whatever's changed
3076 # NOTE: $lastcommit refers to the last commit from previous run
3077 # $lastpicked is the last commit we picked in this run
3080 if ( defined $lastcommit ) {
3081 $lastpicked = $lastcommit ;
3084 my $committotal = scalar ( @commits );
3085 my $commitcount = 0 ;
3087 # Load the head table into $head (for cached lookups during the update process)
3088 foreach my $file ( @
{ $self -> gethead ()} )
3090 $head ->{ $file ->{ name
}} = $file ;
3093 foreach my $commit ( @commits )
3095 $self ->{ log }-> debug ( "GITCVS::updater - Processing commit $commit ->{hash} (" . (++ $commitcount ) . " of $committotal )" );
3096 if ( defined $lastpicked )
3098 if (! in_array
( $lastpicked , @
{ $commit ->{ parents
}}))
3100 # skip, we'll see this delta
3101 # as part of a merge later
3102 # warn "skipping off-track $commit->{hash}\n";
3104 } elsif ( @
{ $commit ->{ parents
}} > 1 ) {
3105 # it is a merge commit, for each parent that is
3106 # not $lastpicked, see if we can get a log
3107 # from the merge-base to that parent to put it
3108 # in the message as a merge summary.
3109 my @parents = @
{ $commit ->{ parents
}};
3110 foreach my $parent ( @parents ) {
3111 # git-merge-base can potentially (but rarely) throw
3112 # several candidate merge bases. let's assume
3113 # that the first one is the best one.
3114 if ( $parent eq $lastpicked ) {
3118 safe_pipe_capture
( 'git' , 'merge-base' ,
3119 $lastpicked , $parent );
3121 # The two branches may not be related at all,
3122 # in which case merge base simply fails to find
3123 # any, but that's Ok.
3129 # print "want to log between $base $parent \n";
3130 open ( GITLOG
, '-|' , 'git' , 'log' , '--pretty=medium' , " $base .. $parent " )
3131 or die "Cannot call git-log: $!" ;
3135 if (! defined $mergedhash ) {
3136 if ( m/^commit\s+(.+)$/ ) {
3142 # grab the first line that looks non-rfc822
3143 # aka has content after leading space
3144 if ( m/^\s+(\S.*)$/ ) {
3146 $title = substr ( $title , 0 , 100 ); # truncate
3147 unshift @merged , " $mergedhash $title " ;
3154 $commit ->{ mergemsg
} = $commit ->{ message
};
3155 $commit ->{ mergemsg
} .= " \n Summary of merged commits: \n\n " ;
3156 foreach my $summary ( @merged ) {
3157 $commit ->{ mergemsg
} .= " \t $summary \n " ;
3159 $commit ->{ mergemsg
} .= " \n\n " ;
3160 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3167 # convert the date to CVS-happy format
3168 $commit ->{ date
} = " $2 $1 $4 $3 $5 " if ( $commit ->{ date
} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
3170 if ( defined ( $lastpicked ) )
3172 my $filepipe = open ( FILELIST
, '-|' , 'git' , 'diff-tree' , '-z' , '-r' , $lastpicked , $commit ->{ hash
}) or die ( "Cannot call git-diff-tree : $!" );
3174 while ( < FILELIST
> )
3177 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)$/o )
3179 die ( "Couldn't process git-diff-tree line : $_ " );
3181 my ( $mode , $hash , $change ) = ( $1 , $2 , $3 );
3182 my $name = < FILELIST
>;
3185 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3188 $git_perms .= "r" if ( $mode & 4 );
3189 $git_perms .= "w" if ( $mode & 2 );
3190 $git_perms .= "x" if ( $mode & 1 );
3191 $git_perms = "rw" if ( $git_perms eq "" );
3193 if ( $change eq "D" )
3195 #$log->debug("DELETE $name");
3198 revision
=> $head ->{ $name }{ revision
} + 1 ,
3199 filehash
=> "deleted" ,
3200 commithash
=> $commit ->{ hash
},
3201 modified
=> $commit ->{ date
},
3202 author
=> $commit ->{ author
},
3205 $self -> insert_rev ( $name , $head ->{ $name }{ revision
}, $hash , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
3207 elsif ( $change eq "M" || $change eq "T" )
3209 #$log->debug("MODIFIED $name");
3212 revision
=> $head ->{ $name }{ revision
} + 1 ,
3214 commithash
=> $commit ->{ hash
},
3215 modified
=> $commit ->{ date
},
3216 author
=> $commit ->{ author
},
3219 $self -> insert_rev ( $name , $head ->{ $name }{ revision
}, $hash , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
3221 elsif ( $change eq "A" )
3223 #$log->debug("ADDED $name");
3226 revision
=> $head ->{ $name }{ revision
} ?
$head ->{ $name }{ revision
}+ 1 : 1 ,
3228 commithash
=> $commit ->{ hash
},
3229 modified
=> $commit ->{ date
},
3230 author
=> $commit ->{ author
},
3233 $self -> insert_rev ( $name , $head ->{ $name }{ revision
}, $hash , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
3237 $log -> warn ( "UNKNOWN FILE CHANGE mode= $mode , hash= $hash , change= $change , name= $name " );
3243 # this is used to detect files removed from the repo
3244 my $seen_files = {};
3246 my $filepipe = open ( FILELIST
, '-|' , 'git' , 'ls-tree' , '-z' , '-r' , $commit ->{ hash
}) or die ( "Cannot call git-ls-tree : $!" );
3248 while ( < FILELIST
> )
3251 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3253 die ( "Couldn't process git-ls-tree line : $_ " );
3256 my ( $git_perms , $git_type , $git_hash , $git_filename ) = ( $1 , $2 , $3 , $4 );
3258 $seen_files ->{ $git_filename } = 1 ;
3260 my ( $oldhash , $oldrevision , $oldmode ) = (
3261 $head ->{ $git_filename }{ filehash
},
3262 $head ->{ $git_filename }{ revision
},
3263 $head ->{ $git_filename }{ mode
}
3266 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
3269 $git_perms .= "r" if ( $1 & 4 );
3270 $git_perms .= "w" if ( $1 & 2 );
3271 $git_perms .= "x" if ( $1 & 1 );
3276 # unless the file exists with the same hash, we need to update it ...
3277 unless ( defined ( $oldhash ) and $oldhash eq $git_hash and defined ( $oldmode ) and $oldmode eq $git_perms )
3279 my $newrevision = ( $oldrevision or 0 ) + 1 ;
3281 $head ->{ $git_filename } = {
3282 name
=> $git_filename ,
3283 revision
=> $newrevision ,
3284 filehash
=> $git_hash ,
3285 commithash
=> $commit ->{ hash
},
3286 modified
=> $commit ->{ date
},
3287 author
=> $commit ->{ author
},
3292 $self -> insert_rev ( $git_filename , $newrevision , $git_hash , $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $git_perms );
3297 # Detect deleted files
3298 foreach my $file ( keys % $head )
3300 unless ( exists $seen_files ->{ $file } or $head ->{ $file }{ filehash
} eq "deleted" )
3302 $head ->{ $file }{ revision
}++;
3303 $head ->{ $file }{ filehash
} = "deleted" ;
3304 $head ->{ $file }{ commithash
} = $commit ->{ hash
};
3305 $head ->{ $file }{ modified
} = $commit ->{ date
};
3306 $head ->{ $file }{ author
} = $commit ->{ author
};
3308 $self -> insert_rev ( $file , $head ->{ $file }{ revision
}, $head ->{ $file }{ filehash
}, $commit ->{ hash
}, $commit ->{ date
}, $commit ->{ author
}, $head ->{ $file }{ mode
});
3311 # END : "Detect deleted files"
3315 if ( exists $commit ->{ mergemsg
})
3317 $self -> insert_mergelog ( $commit ->{ hash
}, $commit ->{ mergemsg
});
3320 $lastpicked = $commit ->{ hash
};
3322 $self -> _set_prop ( "last_commit" , $commit ->{ hash
});
3325 $self -> delete_head ();
3326 foreach my $file ( keys % $head )
3330 $head ->{ $file }{ revision
},
3331 $head ->{ $file }{ filehash
},
3332 $head ->{ $file }{ commithash
},
3333 $head ->{ $file }{ modified
},
3334 $head ->{ $file }{ author
},
3335 $head ->{ $file }{ mode
},
3338 # invalidate the gethead cache
3339 $self ->{ gethead_cache
} = undef ;
3342 # Ending exclusive lock here
3343 $self ->{ dbh
}-> commit () or die "Failed to commit changes to SQLite" ;
3350 my $revision = shift ;
3351 my $filehash = shift ;
3352 my $commithash = shift ;
3353 my $modified = shift ;
3356 my $tablename = $self -> tablename ( "revision" );
3358 my $insert_rev = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)" ,{}, 1 );
3359 $insert_rev -> execute ( $name , $revision , $filehash , $commithash , $modified , $author , $mode );
3367 my $tablename = $self -> tablename ( "commitmsgs" );
3369 my $insert_mergelog = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO $tablename (key, value) VALUES (?,?)" ,{}, 1 );
3370 $insert_mergelog -> execute ( $key , $value );
3376 my $tablename = $self -> tablename ( "head" );
3378 my $delete_head = $self ->{ dbh
}-> prepare_cached ( "DELETE FROM $tablename " ,{}, 1 );
3379 $delete_head -> execute ();
3386 my $revision = shift ;
3387 my $filehash = shift ;
3388 my $commithash = shift ;
3389 my $modified = shift ;
3392 my $tablename = $self -> tablename ( "head" );
3394 my $insert_head = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)" ,{}, 1 );
3395 $insert_head -> execute ( $name , $revision , $filehash , $commithash , $modified , $author , $mode );
3401 my $filename = shift ;
3402 my $tablename = $self -> tablename ( "head" );
3404 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT filehash, revision, mode FROM $tablename WHERE name=?" ,{}, 1 );
3405 $db_query -> execute ( $filename );
3406 my ( $hash , $revision , $mode ) = $db_query -> fetchrow_array ;
3408 return ( $hash , $revision , $mode );
3415 my $tablename = $self -> tablename ( "properties" );
3417 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT value FROM $tablename WHERE key=?" ,{}, 1 );
3418 $db_query -> execute ( $key );
3419 my ( $value ) = $db_query -> fetchrow_array ;
3429 my $tablename = $self -> tablename ( "properties" );
3431 my $db_query = $self ->{ dbh
}-> prepare_cached ( "UPDATE $tablename SET value=? WHERE key=?" ,{}, 1 );
3432 $db_query -> execute ( $value , $key );
3434 unless ( $db_query -> rows )
3436 $db_query = $self ->{ dbh
}-> prepare_cached ( "INSERT INTO $tablename (key, value) VALUES (?,?)" ,{}, 1 );
3437 $db_query -> execute ( $key , $value );
3450 my $tablename = $self -> tablename ( "head" );
3452 return $self ->{ gethead_cache
} if ( defined ( $self ->{ gethead_cache
} ) );
3454 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC" ,{}, 1 );
3455 $db_query -> execute ();
3458 while ( my $file = $db_query -> fetchrow_hashref )
3463 $self ->{ gethead_cache
} = $tree ;
3475 my $filename = shift ;
3476 my $tablename = $self -> tablename ( "revision" );
3478 my $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC" ,{}, 1 );
3479 $db_query -> execute ( $filename );
3482 while ( my $file = $db_query -> fetchrow_hashref )
3492 This function takes a filename (with path) argument and returns a hashref of
3493 metadata for that file.
3500 my $filename = shift ;
3501 my $revision = shift ;
3502 my $tablename_rev = $self -> tablename ( "revision" );
3503 my $tablename_head = $self -> tablename ( "head" );
3506 if ( defined ( $revision ) and $revision =~ /^\d+$/ )
3508 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT * FROM $tablename_rev WHERE name=? AND revision=?" ,{}, 1 );
3509 $db_query -> execute ( $filename , $revision );
3511 elsif ( defined ( $revision ) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
3513 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?" ,{}, 1 );
3514 $db_query -> execute ( $filename , $revision );
3516 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT * FROM $tablename_head WHERE name=?" ,{}, 1 );
3517 $db_query -> execute ( $filename );
3520 return $db_query -> fetchrow_hashref ;
3523 =head2 commitmessage
3525 this function takes a commithash and returns the commit message for that commit
3531 my $commithash = shift ;
3532 my $tablename = $self -> tablename ( "commitmsgs" );
3534 die ( "Need commithash" ) unless ( defined ( $commithash ) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
3537 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT value FROM $tablename WHERE key=?" ,{}, 1 );
3538 $db_query -> execute ( $commithash );
3540 my ( $message ) = $db_query -> fetchrow_array ;
3542 if ( defined ( $message ) )
3544 $message .= " " if ( $message =~ /\n$/ );
3548 my @lines = safe_pipe_capture
( "git" , "cat-file" , "commit" , $commithash );
3549 shift @lines while ( $lines [ 0 ] =~ /\S/ );
3550 $message = join ( "" , @lines );
3551 $message .= " " if ( $message =~ /\n$/ );
3557 This function takes a filename (with path) argument and returns an arrayofarrays
3558 containing revision,filehash,commithash ordered by revision descending
3564 my $filename = shift ;
3565 my $tablename = $self -> tablename ( "revision" );
3568 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT revision, filehash, commithash FROM $tablename WHERE name=? ORDER BY revision DESC" ,{}, 1 );
3569 $db_query -> execute ( $filename );
3571 return $db_query -> fetchall_arrayref ;
3574 =head2 gethistorydense
3576 This function takes a filename (with path) argument and returns an arrayofarrays
3577 containing revision,filehash,commithash ordered by revision descending.
3579 This version of gethistory skips deleted entries -- so it is useful for annotate.
3580 The 'dense' part is a reference to a '--dense' option available for git-rev-list
3581 and other git tools that depend on it.
3587 my $filename = shift ;
3588 my $tablename = $self -> tablename ( "revision" );
3591 $db_query = $self ->{ dbh
}-> prepare_cached ( "SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC" ,{}, 1 );
3592 $db_query -> execute ( $filename );
3594 return $db_query -> fetchall_arrayref ;
3599 from Array::PAT - mimics the in_array() function
3600 found in PHP. Yuck but works for small arrays.
3605 my ( $check , @array ) = @_ ;
3607 foreach my $test ( @array ){
3608 if ( $check eq $test ){
3615 =head2 safe_pipe_capture
3617 an alternative to `command` that allows input to be passed as an array
3618 to work around shell problems with weird characters in arguments
3621 sub safe_pipe_capture
{
3625 if ( my $pid = open my $child , '-|' ) {
3626 @output = (< $child >);
3627 close $child or die join ( ' ' , @_ ). ": $! $?" ;
3629 exec ( @_ ) or die "$! $?" ; # exec() can fail the executable can't be found
3631 return wantarray ?
@output : join ( '' , @output );
3634 =head2 mangle_dirname
3636 create a string from a directory name that is suitable to use as
3637 part of a filename, mainly by converting all chars except \w.- to _
3640 sub mangle_dirname
{
3641 my $dirname = shift ;
3642 return unless defined $dirname ;
3644 $dirname =~ s/[^\w.-]/_/g ;
3649 =head2 mangle_tablename
3651 create a string from a that is suitable to use as part of an SQL table
3652 name, mainly by converting all chars except \w to _
3655 sub mangle_tablename
{
3656 my $tablename = shift ;
3657 return unless defined $tablename ;
3659 $tablename =~ s/[^\w_]/_/g ;