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@laptop.org>
14 #### Released under the GNU Public License, version 2.
24 use File
::Temp
qw/tempdir tempfile/;
25 use File
::Path
qw/rmtree/;
27 use Getopt
::Long
qw(:config require_order no_ignore_case
);
29 my $VERSION = '@@GIT_VERSION@@';
31 my $log = GITCVS
::log->new();
49 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
52 #### Definition and mappings of functions ####
54 # NOTE: Despite the existence of req_CATCHALL and req_EMPTY unimplemented
55 # requests, this list is incomplete. It is missing many rarer/optional
56 # requests. Perhaps some clients require a claim of support for
57 # these specific requests for main functionality to work?
60 'Valid-responses' => \
&req_Validresponses
,
61 'valid-requests' => \
&req_validrequests
,
62 'Directory' => \
&req_Directory
,
63 'Sticky' => \
&req_Sticky
,
64 'Entry' => \
&req_Entry
,
65 'Modified' => \
&req_Modified
,
66 'Unchanged' => \
&req_Unchanged
,
67 'Questionable' => \
&req_Questionable
,
68 'Argument' => \
&req_Argument
,
69 'Argumentx' => \
&req_Argument
,
70 'expand-modules' => \
&req_expandmodules
,
72 'remove' => \
&req_remove
,
74 'update' => \
&req_update
,
79 'tag' => \
&req_CATCHALL
,
80 'status' => \
&req_status
,
81 'admin' => \
&req_CATCHALL
,
82 'history' => \
&req_CATCHALL
,
83 'watchers' => \
&req_EMPTY
,
84 'editors' => \
&req_EMPTY
,
85 'noop' => \
&req_EMPTY
,
86 'annotate' => \
&req_annotate
,
87 'Global_option' => \
&req_Globaloption
,
90 ##############################################
93 # $state holds all the bits of information the clients sends us that could
94 # potentially be useful when it comes to actually _doing_ something.
95 my $state = { prependdir
=> '' };
97 # Work is for managing temporary working directory
100 state => undef, # undef, 1 (empty), 2 (with stuff)
107 $log->info("--------------- STARTING -----------------");
110 "usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
111 " --base-path <path> : Prepend to requested CVSROOT\n".
112 " Can be read from GIT_CVSSERVER_BASE_PATH\n".
113 " --strict-paths : Don't allow recursing into subdirectories\n".
114 " --export-all : Don't check for gitcvs.enabled in config\n".
115 " --version, -V : Print version information and exit\n".
116 " -h, -H : Print usage information and exit\n".
118 "<directory> ... is a list of allowed directories. If no directories\n".
119 "are given, all are allowed. This is an additional restriction, gitcvs\n".
120 "access still needs to be enabled by the gitcvs.enabled config option.\n".
121 "Alternately, one directory may be specified in GIT_CVSSERVER_ROOT.\n";
123 my @opts = ( 'h|H', 'version|V',
124 'base-path=s', 'strict-paths', 'export-all' );
125 GetOptions
( $state, @opts )
128 if ($state->{version
}) {
129 print "git-cvsserver version $VERSION\n";
132 if ($state->{help
}) {
137 my $TEMP_DIR = tempdir
( CLEANUP
=> 1 );
138 $log->debug("Temporary directory is '$TEMP_DIR'");
140 $state->{method
} = 'ext';
142 if ($ARGV[0] eq 'pserver') {
143 $state->{method
} = 'pserver';
145 } elsif ($ARGV[0] eq 'server') {
150 # everything else is a directory
151 $state->{allowed_roots
} = [ @ARGV ];
153 # don't export the whole system unless the users requests it
154 if ($state->{'export-all'} && !@
{$state->{allowed_roots
}}) {
155 die "--export-all can only be used together with an explicit whitelist\n";
158 # Environment handling for running under git-shell
159 if (exists $ENV{GIT_CVSSERVER_BASE_PATH
}) {
160 if ($state->{'base-path'}) {
161 die "Cannot specify base path both ways.\n";
163 my $base_path = $ENV{GIT_CVSSERVER_BASE_PATH
};
164 $state->{'base-path'} = $base_path;
165 $log->debug("Picked up base path '$base_path' from environment.\n");
167 if (exists $ENV{GIT_CVSSERVER_ROOT
}) {
168 if (@
{$state->{allowed_roots
}}) {
169 die "Cannot specify roots both ways: @ARGV\n";
171 my $allowed_root = $ENV{GIT_CVSSERVER_ROOT
};
172 $state->{allowed_roots
} = [ $allowed_root ];
173 $log->debug("Picked up allowed root '$allowed_root' from environment.\n");
176 # if we are called with a pserver argument,
177 # deal with the authentication cat before entering the
179 if ($state->{method
} eq 'pserver') {
180 my $line = <STDIN
>; chomp $line;
181 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
182 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
185 $line = <STDIN
>; chomp $line;
186 unless (req_Root
('root', $line)) { # reuse Root
187 print "E Invalid root $line \n";
190 $line = <STDIN
>; chomp $line;
192 $line = <STDIN
>; chomp $line;
193 my $password = $line;
195 if ($user eq 'anonymous') {
196 # "A" will be 1 byte, use length instead in case the
197 # encryption method ever changes (yeah, right!)
198 if (length($password) > 1 ) {
199 print "E Don't supply a password for the `anonymous' user\n";
200 print "I HATE YOU\n";
204 # Fall through to LOVE
206 # Trying to authenticate a user
207 if (not exists $cfg->{gitcvs
}->{authdb
}) {
208 print "E the repo config file needs a [gitcvs] section with an 'authdb' parameter set to the filename of the authentication database\n";
209 print "I HATE YOU\n";
213 my $authdb = $cfg->{gitcvs
}->{authdb
};
215 unless (-e
$authdb) {
216 print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
217 print "I HATE YOU\n";
222 open my $passwd, "<", $authdb or die $!;
224 if (m{^\Q$user\E:(.*)}) {
225 if (crypt($user, descramble
($password)) eq $1) {
233 print "I HATE YOU\n";
237 # Fall through to LOVE
240 # For checking whether the user is anonymous on commit
241 $state->{user
} = $user;
243 $line = <STDIN
>; chomp $line;
244 unless ($line eq "END $request REQUEST") {
245 die "E Do not understand $line -- expecting END $request REQUEST\n";
247 print "I LOVE YOU\n";
248 exit if $request eq 'VERIFICATION'; # cvs login
249 # and now back to our regular programme...
252 # Keep going until the client closes the connection
257 # Check to see if we've seen this method, and call appropriate function.
258 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
260 # use the $methods hash to call the appropriate sub for this command
261 #$log->info("Method : $1");
262 &{$methods->{$1}}($1,$2);
264 # log fatal because we don't understand this function. If this happens
265 # we're fairly screwed because we don't know if the client is expecting
266 # a response. If it is, the client will hang, we'll hang, and the whole
267 # thing will be custard.
268 $log->fatal("Don't understand command $_\n");
269 die("Unknown command $_");
273 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
274 $log->info("--------------- FINISH -----------------");
279 # Magic catchall method.
280 # This is the method that will handle all commands we haven't yet
281 # implemented. It simply sends a warning to the log file indicating a
282 # command that hasn't been implemented has been invoked.
285 my ( $cmd, $data ) = @_;
286 $log->warn("Unhandled command : req_$cmd : $data");
289 # This method invariably succeeds with an empty response.
296 # Response expected: no. Tell the server which CVSROOT to use. Note that
297 # pathname is a local directory and not a fully qualified CVSROOT variable.
298 # pathname must already exist; if creating a new root, use the init
299 # request, not Root. pathname does not include the hostname of the server,
300 # how to access the server, etc.; by the time the CVS protocol is in use,
301 # connection, authentication, etc., are already taken care of. The Root
302 # request must be sent only once, and it must be sent before any requests
303 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
306 my ( $cmd, $data ) = @_;
307 $log->debug("req_Root : $data");
309 unless ($data =~ m
#^/#) {
310 print "error 1 Root must be an absolute pathname\n";
314 my $cvsroot = $state->{'base-path'} || '';
318 if ($state->{CVSROOT
}
319 && ($state->{CVSROOT
} ne $cvsroot)) {
320 print "error 1 Conflicting roots specified\n";
324 $state->{CVSROOT
} = $cvsroot;
326 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
328 if (@
{$state->{allowed_roots
}}) {
330 foreach my $dir (@
{$state->{allowed_roots
}}) {
331 next unless $dir =~ m
#^/#;
333 if ($state->{'strict-paths'}) {
334 if ($ENV{GIT_DIR
} =~ m
#^\Q$dir\E/?$#) {
338 } elsif ($ENV{GIT_DIR
} =~ m
#^\Q$dir\E(/?$|/)#) {
345 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
347 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
352 unless (-d
$ENV{GIT_DIR
} && -e
$ENV{GIT_DIR
}.'HEAD') {
353 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
355 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
359 my @gitvars = safe_pipe_capture
(qw(git config
-l
));
361 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
363 print "error 1 - problem executing git-config\n";
366 foreach my $line ( @gitvars )
368 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
372 $cfg->{$1}{$2}{$3} = $4;
376 my $enabled = ($cfg->{gitcvs
}{$state->{method
}}{enabled
}
377 || $cfg->{gitcvs
}{enabled
});
378 unless ($state->{'export-all'} ||
379 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
380 print "E GITCVS emulation needs to be enabled on this repo\n";
381 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
383 print "error 1 GITCVS emulation disabled\n";
387 my $logfile = $cfg->{gitcvs
}{$state->{method
}}{logfile
} || $cfg->{gitcvs
}{logfile
};
390 $log->setfile($logfile);
398 # Global_option option \n
399 # Response expected: no. Transmit one of the global options `-q', `-Q',
400 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
401 # variations (such as combining of options) are allowed. For graceful
402 # handling of valid-requests, it is probably better to make new global
403 # options separate requests, rather than trying to add them to this
407 my ( $cmd, $data ) = @_;
408 $log->debug("req_Globaloption : $data");
409 $state->{globaloptions
}{$data} = 1;
412 # Valid-responses request-list \n
413 # Response expected: no. Tell the server what responses the client will
414 # accept. request-list is a space separated list of tokens.
415 sub req_Validresponses
417 my ( $cmd, $data ) = @_;
418 $log->debug("req_Validresponses : $data");
420 # TODO : re-enable this, currently it's not particularly useful
421 #$state->{validresponses} = [ split /\s+/, $data ];
425 # Response expected: yes. Ask the server to send back a Valid-requests
427 sub req_validrequests
429 my ( $cmd, $data ) = @_;
431 $log->debug("req_validrequests");
433 $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods));
434 $log->debug("SEND : ok");
436 print "Valid-requests " . join(" ",sort keys %$methods) . "\n";
440 # Directory local-directory \n
441 # Additional data: repository \n. Response expected: no. Tell the server
442 # what directory to use. The repository should be a directory name from a
443 # previous server response. Note that this both gives a default for Entry
444 # and Modified and also for ci and the other commands; normal usage is to
445 # send Directory for each directory in which there will be an Entry or
446 # Modified, and then a final Directory for the original directory, then the
447 # command. The local-directory is relative to the top level at which the
448 # command is occurring (i.e. the last Directory which is sent before the
449 # command); to indicate that top level, `.' should be sent for
453 my ( $cmd, $data ) = @_;
455 my $repository = <STDIN
>;
459 $state->{localdir
} = $data;
460 $state->{repository
} = $repository;
461 $state->{path
} = $repository;
462 $state->{path
} =~ s/^\Q$state->{CVSROOT}\E\///;
463 $state->{module
} = $1 if ($state->{path
} =~ s/^(.*?)(\/|$)//);
464 $state->{path
} .= "/" if ( $state->{path} =~ /\S/ );
466 $state->{directory} = $state->{localdir};
467 $state->{directory} = "" if ( $state->{directory} eq "." );
468 $state->{directory} .= "/" if ( $state->{directory} =~ /\S
/ );
470 if ( (not defined($state->{prependdir
}) or $state->{prependdir
} eq '') and $state->{localdir
} eq "." and $state->{path
} =~ /\S/ )
472 $log->info("Setting prepend to '$state->{path}'");
473 $state->{prependdir
} = $state->{path
};
475 foreach my $entry ( keys %{$state->{entries
}} )
477 $entries{$state->{prependdir
} . $entry} = $state->{entries
}{$entry};
479 $state->{entries
}=\
%entries;
482 foreach my $dir ( keys %{$state->{dirMap
}} )
484 $dirMap{$state->{prependdir
} . $dir} = $state->{dirMap
}{$dir};
486 $state->{dirMap
}=\
%dirMap;
489 if ( defined ( $state->{prependdir
} ) )
491 $log->debug("Prepending '$state->{prependdir}' to state|directory");
492 $state->{directory
} = $state->{prependdir
} . $state->{directory
}
495 if ( ! defined($state->{dirMap
}{$state->{directory
}}) )
497 $state->{dirMap
}{$state->{directory
}} =
504 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
508 # Response expected: no. Tell the server that the directory most
509 # recently specified with Directory has a sticky tag or date
510 # tagspec. The first character of tagspec is T for a tag, D for
511 # a date, or some other character supplied by a Set-sticky
512 # response from a previous request to the server. The remainder
513 # of tagspec contains the actual tag or date, again as supplied
515 # The server should remember Static-directory and Sticky requests
516 # for a particular directory; the client need not resend them each
517 # time it sends a Directory request for a given directory. However,
518 # the server is not obliged to remember them beyond the context
519 # of a single command.
522 my ( $cmd, $tagspec ) = @_;
529 elsif($tagspec=~/^T([^ ]+)\s*$/)
531 $stickyInfo = { 'tag' => $1 };
533 elsif($tagspec=~/^D([0-9.]+)\s*$/)
535 $stickyInfo= { 'date' => $1 };
539 die "Unknown tag_or_date format\n";
541 $state->{dirMap
}{$state->{directory
}}{stickyInfo
}=$stickyInfo;
543 $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}"
544 . " path=$state->{path} directory=$state->{directory}"
545 . " module=$state->{module}");
548 # Entry entry-line \n
549 # Response expected: no. Tell the server what version of a file is on the
550 # local machine. The name in entry-line is a name relative to the directory
551 # most recently specified with Directory. If the user is operating on only
552 # some files in a directory, Entry requests for only those files need be
553 # included. If an Entry request is sent without Modified, Is-modified, or
554 # Unchanged, it means the file is lost (does not exist in the working
555 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
556 # are sent for the same file, Entry must be sent first. For a given file,
557 # one can send Modified, Is-modified, or Unchanged, but not more than one
561 my ( $cmd, $data ) = @_;
563 #$log->debug("req_Entry : $data");
565 my @data = split(/\//, $data, -1);
567 $state->{entries
}{$state->{directory
}.$data[1]} = {
568 revision
=> $data[2],
569 conflict
=> $data[3],
571 tag_or_date
=> $data[5],
574 $state->{dirMap
}{$state->{directory
}}{names
}{$data[1]} = 'F';
576 $log->info("Received entry line '$data' => '" . $state->{directory
} . $data[1] . "'");
579 # Questionable filename \n
580 # Response expected: no. Additional data: no. Tell the server to check
581 # whether filename should be ignored, and if not, next time the server
582 # sends responses, send (in a M response) `?' followed by the directory and
583 # filename. filename must not contain `/'; it needs to be a file in the
584 # directory named by the most recent Directory request.
587 my ( $cmd, $data ) = @_;
589 $log->debug("req_Questionable : $data");
590 $state->{entries
}{$state->{directory
}.$data}{questionable
} = 1;
594 # Response expected: yes. Add a file or directory. This uses any previous
595 # Argument, Directory, Entry, or Modified requests, if they have been sent.
596 # The last Directory sent specifies the working directory at the time of
597 # the operation. To add a directory, send the directory to be added using
598 # Directory and Argument requests.
601 my ( $cmd, $data ) = @_;
605 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
610 foreach my $filename ( @
{$state->{args
}} )
612 $filename = filecleanup
($filename);
614 # no -r, -A, or -D with add
615 my $stickyInfo = resolveStickyInfo
($filename);
617 my $meta = $updater->getmeta($filename,$stickyInfo);
618 my $wrev = revparse
($filename);
620 if ($wrev && $meta && ($wrev=~/^-/))
622 # previously removed file, add back
623 $log->info("added file $filename was previously removed, send $meta->{revision}");
625 print "MT +updated\n";
626 print "MT text U \n";
627 print "MT fname $filename\n";
628 print "MT newline\n";
629 print "MT -updated\n";
631 unless ( $state->{globaloptions
}{-n
} )
633 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
635 print "Created $dirpart\n";
636 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
638 # this is an "entries" line
639 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
640 my $entryLine = "/$filepart/$meta->{revision}//$kopts/";
641 $entryLine .= getStickyTagOrDate
($stickyInfo);
642 $log->debug($entryLine);
643 print "$entryLine\n";
645 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
646 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
648 transmitfile
($meta->{filehash
});
654 unless ( defined ( $state->{entries
}{$filename}{modified_filename
} ) )
656 print "E cvs add: nothing known about `$filename'\n";
659 # TODO : check we're not squashing an already existing file
660 if ( defined ( $state->{entries
}{$filename}{revision
} ) )
662 print "E cvs add: `$filename' has already been entered\n";
666 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
668 print "E cvs add: scheduling file `$filename' for addition\n";
670 print "Checked-in $dirpart\n";
672 my $kopts = kopts_from_path
($filename,"file",
673 $state->{entries
}{$filename}{modified_filename
});
674 print "/$filepart/0//$kopts/" .
675 getStickyTagOrDate
($stickyInfo) . "\n";
677 my $requestedKopts = $state->{opt
}{k
};
678 if(defined($requestedKopts))
680 $requestedKopts = "-k$requestedKopts";
684 $requestedKopts = "";
686 if( $kopts ne $requestedKopts )
688 $log->warn("Ignoring requested -k='$requestedKopts'"
689 . " for '$filename'; detected -k='$kopts' instead");
690 #TODO: Also have option to send warning to user?
696 if ( $addcount == 1 )
698 print "E cvs add: use `cvs commit' to add this file permanently\n";
700 elsif ( $addcount > 1 )
702 print "E cvs add: use `cvs commit' to add these files permanently\n";
709 # Response expected: yes. Remove a file. This uses any previous Argument,
710 # Directory, Entry, or Modified requests, if they have been sent. The last
711 # Directory sent specifies the working directory at the time of the
712 # operation. Note that this request does not actually do anything to the
713 # repository; the only effect of a successful remove request is to supply
714 # the client with a new entries line containing `-' to indicate a removed
715 # file. In fact, the client probably could perform this operation without
716 # contacting the server, although using remove may cause the server to
717 # perform a few more checks. The client sends a subsequent ci request to
718 # actually record the removal in the repository.
721 my ( $cmd, $data ) = @_;
725 # Grab a handle to the SQLite db and do any necessary updates
726 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
729 #$log->debug("add state : " . Dumper($state));
733 foreach my $filename ( @
{$state->{args
}} )
735 $filename = filecleanup
($filename);
737 if ( defined ( $state->{entries
}{$filename}{unchanged
} ) or defined ( $state->{entries
}{$filename}{modified_filename
} ) )
739 print "E cvs remove: file `$filename' still in working directory\n";
744 my $stickyInfo = resolveStickyInfo
($filename);
746 my $meta = $updater->getmeta($filename,$stickyInfo);
747 my $wrev = revparse
($filename);
749 unless ( defined ( $wrev ) )
751 print "E cvs remove: nothing known about `$filename'\n";
755 if ( defined($wrev) and ($wrev=~/^-/) )
757 print "E cvs remove: file `$filename' already scheduled for removal\n";
761 unless ( $wrev eq $meta->{revision
} )
763 # TODO : not sure if the format of this message is quite correct.
764 print "E cvs remove: Up to date check failed for `$filename'\n";
769 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
771 print "E cvs remove: scheduling `$filename' for removal\n";
773 print "Checked-in $dirpart\n";
775 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
776 print "/$filepart/-$wrev//$kopts/" . getStickyTagOrDate
($stickyInfo) . "\n";
783 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
785 elsif ( $rmcount > 1 )
787 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
793 # Modified filename \n
794 # Response expected: no. Additional data: mode, \n, file transmission. Send
795 # the server a copy of one locally modified file. filename is a file within
796 # the most recent directory sent with Directory; it must not contain `/'.
797 # If the user is operating on only some files in a directory, only those
798 # files need to be included. This can also be sent without Entry, if there
799 # is no entry for the file.
802 my ( $cmd, $data ) = @_;
806 or (print "E end of file reading mode for $data\n"), return;
810 or (print "E end of file reading size of $data\n"), return;
813 # Grab config information
814 my $blocksize = 8192;
815 my $bytesleft = $size;
818 # Get a filehandle/name to write it to
819 my ( $fh, $filename ) = tempfile
( DIR
=> $TEMP_DIR );
821 # Loop over file data writing out to temporary file.
824 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
825 read STDIN
, $tmp, $blocksize;
827 $bytesleft -= $blocksize;
831 or (print "E failed to write temporary, $filename: $!\n"), return;
833 # Ensure we have something sensible for the file mode
834 if ( $mode =~ /u=(\w+)/ )
841 # Save the file data in $state
842 $state->{entries
}{$state->{directory
}.$data}{modified_filename
} = $filename;
843 $state->{entries
}{$state->{directory
}.$data}{modified_mode
} = $mode;
844 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} = safe_pipe_capture
('git','hash-object',$filename);
845 $state->{entries
}{$state->{directory
}.$data}{modified_hash
} =~ s/\s.*$//s;
847 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
850 # Unchanged filename \n
851 # Response expected: no. Tell the server that filename has not been
852 # modified in the checked out directory. The filename is a file within the
853 # most recent directory sent with Directory; it must not contain `/'.
856 my ( $cmd, $data ) = @_;
858 $state->{entries
}{$state->{directory
}.$data}{unchanged
} = 1;
860 #$log->debug("req_Unchanged : $data");
864 # Response expected: no. Save argument for use in a subsequent command.
865 # Arguments accumulate until an argument-using command is given, at which
866 # point they are forgotten.
868 # Response expected: no. Append \n followed by text to the current argument
872 my ( $cmd, $data ) = @_;
874 # Argumentx means: append to last Argument (with a newline in front)
876 $log->debug("$cmd : $data");
878 if ( $cmd eq 'Argumentx') {
879 ${$state->{arguments
}}[$#{$state->{arguments}}] .= "\n" . $data;
881 push @
{$state->{arguments
}}, $data;
886 # Response expected: yes. Expand the modules which are specified in the
887 # arguments. Returns the data in Module-expansion responses. Note that the
888 # server can assume that this is checkout or export, not rtag or rdiff; the
889 # latter do not access the working directory and thus have no need to
890 # expand modules on the client side. Expand may not be the best word for
891 # what this request does. It does not necessarily tell you all the files
892 # contained in a module, for example. Basically it is a way of telling you
893 # which working directories the server needs to know about in order to
894 # handle a checkout of the specified modules. For example, suppose that the
895 # server has a module defined by
896 # aliasmodule -a 1dir
897 # That is, one can check out aliasmodule and it will take 1dir in the
898 # repository and check it out to 1dir in the working directory. Now suppose
899 # the client already has this module checked out and is planning on using
900 # the co request to update it. Without using expand-modules, the client
901 # would have two bad choices: it could either send information about all
902 # working directories under the current directory, which could be
903 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
904 # stands for 1dir, and neglect to send information for 1dir, which would
905 # lead to incorrect operation. With expand-modules, the client would first
906 # ask for the module to be expanded:
907 sub req_expandmodules
909 my ( $cmd, $data ) = @_;
913 $log->debug("req_expandmodules : " . ( defined($data) ?
$data : "[NULL]" ) );
915 unless ( ref $state->{arguments
} eq "ARRAY" )
921 foreach my $module ( @
{$state->{arguments
}} )
923 $log->debug("SEND : Module-expansion $module");
924 print "Module-expansion $module\n";
932 # Response expected: yes. Get files from the repository. This uses any
933 # previous Argument, Directory, Entry, or Modified requests, if they have
934 # been sent. Arguments to this command are module names; the client cannot
935 # know what directories they correspond to except by (1) just sending the
936 # co request, and then seeing what directory names the server sends back in
937 # its responses, and (2) the expand-modules request.
940 my ( $cmd, $data ) = @_;
944 # Provide list of modules, if -c was used.
945 if (exists $state->{opt
}{c
}) {
946 my $showref = safe_pipe_capture
(qw(git show
-ref --heads
));
947 for my $line (split '\n', $showref) {
948 if ( $line =~ m
% refs
/heads/(.*)$% ) {
956 my $stickyInfo = { 'tag' => $state->{opt
}{r
},
957 'date' => $state->{opt
}{D
} };
959 my $module = $state->{args
}[0];
960 $state->{module
} = $module;
961 my $checkout_path = $module;
963 # use the user specified directory if we're given it
964 $checkout_path = $state->{opt
}{d
} if ( exists ( $state->{opt
}{d
} ) );
966 $log->debug("req_co : " . ( defined($data) ?
$data : "[NULL]" ) );
968 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
970 $ENV{GIT_DIR
} = $state->{CVSROOT
} . "/";
972 # Grab a handle to the SQLite db and do any necessary updates
973 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $module, $log);
977 if( defined($stickyInfo) && defined($stickyInfo->{tag
}) )
979 $headHash = $updater->lookupCommitRef($stickyInfo->{tag
});
980 if( !defined($headHash) )
982 print "error 1 no such tag `$stickyInfo->{tag}'\n";
988 $checkout_path =~ s
|/$||; # get rid of trailing slashes
995 $state->{CVSROOT
} . "/$module",
1001 foreach my $git ( @
{$updater->getAnyHead($headHash)} )
1003 # Don't want to check out deleted files
1004 next if ( $git->{filehash
} eq "deleted" );
1006 my $fullName = $git->{name
};
1007 ( $git->{name
}, $git->{dir
} ) = filenamesplit
($git->{name
});
1009 unless (exists($seendirs{$git->{dir
}})) {
1010 prepDirForOutput
($git->{dir
}, $state->{CVSROOT
} . "/$module/",
1011 $checkout_path, \
%seendirs, 'checkout',
1012 $state->{dirArgs
} );
1013 $lastdir = $git->{dir
};
1014 $seendirs{$git->{dir
}} = 1;
1017 # modification time of this file
1018 print "Mod-time $git->{modified}\n";
1020 # print some information to the client
1021 if ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" )
1023 print "M U $checkout_path/$git->{dir}$git->{name}\n";
1025 print "M U $checkout_path/$git->{name}\n";
1028 # instruct client we're sending a file to put in this path
1029 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ?
$git->{dir
} . "/" : "" ) . "\n";
1031 print $state->{CVSROOT
} . "/$module/" . ( defined ( $git->{dir
} ) and $git->{dir
} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
1033 # this is an "entries" line
1034 my $kopts = kopts_from_path
($fullName,"sha1",$git->{filehash
});
1035 print "/$git->{name}/$git->{revision}//$kopts/" .
1036 getStickyTagOrDate
($stickyInfo) . "\n";
1038 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1041 transmitfile
($git->{filehash
});
1049 # used by req_co and req_update to set up directories for files
1050 # recursively handles parents
1051 sub prepDirForOutput
1053 my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_;
1055 my $parent = dirname
($dir);
1057 $repodir =~ s
|/+$||;
1058 $remotedir =~ s
|/+$||;
1061 if ($parent eq '.' || $parent eq './')
1065 # recurse to announce unseen parents first
1066 if( length($parent) &&
1067 !exists($seendirs->{$parent}) &&
1068 ( $request eq "checkout" ||
1069 exists($dirArgs->{$parent}) ) )
1071 prepDirForOutput
($parent, $repodir, $remotedir,
1072 $seendirs, $request, $dirArgs);
1074 # Announce that we are going to modify at the parent level
1075 if ($dir eq '.' || $dir eq './')
1079 if(exists($seendirs->{$dir}))
1083 $log->debug("announcedir $dir, $repodir, $remotedir" );
1084 my($thisRemoteDir,$thisRepoDir);
1087 $thisRepoDir="$repodir/$dir";
1088 if($remotedir eq ".")
1090 $thisRemoteDir=$dir;
1094 $thisRemoteDir="$remotedir/$dir";
1099 $thisRepoDir=$repodir;
1100 $thisRemoteDir=$remotedir;
1102 unless ( $state->{globaloptions
}{-Q
} || $state->{globaloptions
}{-q} )
1104 print "E cvs $request: Updating $thisRemoteDir\n";
1107 my ($opt_r)=$state->{opt
}{r
};
1109 if(exists($state->{opt
}{A
}))
1111 # $stickyInfo=undef;
1113 elsif( defined($opt_r) && $opt_r ne "" )
1114 # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO
1116 $stickyInfo={ 'tag' => (defined($opt_r)?
$opt_r:undef) };
1118 # TODO: Convert -D value into the form 2011.04.10.04.46.57,
1119 # similar to an entry line's sticky date, without the D prefix.
1120 # It sometimes (always?) arrives as something more like
1121 # '10 Apr 2011 04:46:57 -0000'...
1122 # $stickyInfo={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
1126 $stickyInfo=getDirStickyInfo
($state->{prependdir
} . $dir);
1130 if(defined($stickyInfo))
1132 $stickyResponse = "Set-sticky $thisRemoteDir/\n" .
1134 getStickyTagOrDate
($stickyInfo) . "\n";
1138 $stickyResponse = "Clear-sticky $thisRemoteDir/\n" .
1142 unless ( $state->{globaloptions
}{-n
} )
1144 print $stickyResponse;
1146 print "Clear-static-directory $thisRemoteDir/\n";
1147 print "$thisRepoDir/\n";
1148 print $stickyResponse; # yes, twice
1149 print "Template $thisRemoteDir/\n";
1150 print "$thisRepoDir/\n";
1154 $seendirs->{$dir} = 1;
1156 # FUTURE: This would more accurately emulate CVS by sending
1157 # another copy of sticky after processing the files in that
1158 # directory. Or intermediate: perhaps send all sticky's for
1159 # $seendirs after processing all files.
1163 # Response expected: yes. Actually do a cvs update command. This uses any
1164 # previous Argument, Directory, Entry, or Modified requests, if they have
1165 # been sent. The last Directory sent specifies the working directory at the
1166 # time of the operation. The -I option is not used--files which the client
1167 # can decide whether to ignore are not mentioned and the client sends the
1168 # Questionable request for others.
1171 my ( $cmd, $data ) = @_;
1173 $log->debug("req_update : " . ( defined($data) ?
$data : "[NULL]" ));
1178 # It may just be a client exploring the available heads/modules
1179 # in that case, list them as top level directories and leave it
1180 # at that. Eclipse uses this technique to offer you a list of
1181 # projects (heads in this case) to checkout.
1183 if ($state->{module
} eq '') {
1184 my $showref = safe_pipe_capture
(qw(git show
-ref --heads
));
1185 print "E cvs update: Updating .\n";
1186 for my $line (split '\n', $showref) {
1187 if ( $line =~ m
% refs
/heads/(.*)$% ) {
1188 print "E cvs update: New directory `$1'\n";
1196 # Grab a handle to the SQLite db and do any necessary updates
1197 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1201 argsfromdir
($updater);
1203 #$log->debug("update state : " . Dumper($state));
1206 $repoDir=$state->{CVSROOT
} . "/$state->{module}/$state->{prependdir}";
1210 # foreach file specified on the command line ...
1211 foreach my $argsFilename ( @
{$state->{args
}} )
1214 $filename = filecleanup
($argsFilename);
1216 $log->debug("Processing file $filename");
1218 # if we have a -C we should pretend we never saw modified stuff
1219 if ( exists ( $state->{opt
}{C
} ) )
1221 delete $state->{entries
}{$filename}{modified_hash
};
1222 delete $state->{entries
}{$filename}{modified_filename
};
1223 $state->{entries
}{$filename}{unchanged
} = 1;
1226 my $stickyInfo = resolveStickyInfo
($filename,
1229 exists($state->{opt
}{A
}));
1230 my $meta = $updater->getmeta($filename, $stickyInfo);
1232 # If -p was given, "print" the contents of the requested revision.
1233 if ( exists ( $state->{opt
}{p
} ) ) {
1234 if ( defined ( $meta->{revision
} ) ) {
1235 $log->info("Printing '$filename' revision " . $meta->{revision
});
1237 transmitfile
($meta->{filehash
}, { print => 1 });
1245 dirname
($argsFilename),
1250 $state->{dirArgs
} );
1252 my $wrev = revparse
($filename);
1254 if ( ! defined $meta )
1263 $meta->{filehash
}='deleted';
1267 my $oldmeta = $meta;
1269 # If the working copy is an old revision, lets get that version too for comparison.
1271 if(defined($oldWrev))
1274 if($oldWrev ne $meta->{revision
})
1276 $oldmeta = $updater->getmeta($filename, $oldWrev);
1280 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1282 # Files are up to date if the working copy and repo copy have the same revision,
1283 # and the working copy is unmodified _and_ the user hasn't specified -C
1284 next if ( defined ( $wrev )
1285 and defined($meta->{revision
})
1286 and $wrev eq $meta->{revision
}
1287 and $state->{entries
}{$filename}{unchanged
}
1288 and not exists ( $state->{opt
}{C
} ) );
1290 # If the working copy and repo copy have the same revision,
1291 # but the working copy is modified, tell the client it's modified
1292 if ( defined ( $wrev )
1293 and defined($meta->{revision
})
1294 and $wrev eq $meta->{revision
}
1296 and defined($state->{entries
}{$filename}{modified_hash
})
1297 and not exists ( $state->{opt
}{C
} ) )
1299 $log->info("Tell the client the file is modified");
1300 print "MT text M \n";
1301 print "MT fname $filename\n";
1302 print "MT newline\n";
1306 if ( $meta->{filehash
} eq "deleted" && $wrev ne "0" )
1308 # TODO: If it has been modified in the sandbox, error out
1309 # with the appropriate message, rather than deleting a modified
1312 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
1314 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1316 print "E cvs update: `$filename' is no longer in the repository\n";
1317 # Don't want to actually _DO_ the update if -n specified
1318 unless ( $state->{globaloptions
}{-n
} ) {
1319 print "Removed $dirpart\n";
1320 print "$filepart\n";
1323 elsif ( not defined ( $state->{entries
}{$filename}{modified_hash
} )
1324 or $state->{entries
}{$filename}{modified_hash
} eq $oldmeta->{filehash
}
1325 or $meta->{filehash
} eq 'added' )
1327 # normal update, just send the new revision (either U=Update,
1328 # or A=Add, or R=Remove)
1329 if ( defined($wrev) && ($wrev=~/^-/) )
1331 $log->info("Tell the client the file is scheduled for removal");
1332 print "MT text R \n";
1333 print "MT fname $filename\n";
1334 print "MT newline\n";
1337 elsif ( (!defined($wrev) || $wrev eq '0') &&
1338 (!defined($meta->{revision
}) || $meta->{revision
} eq '0') )
1340 $log->info("Tell the client the file is scheduled for addition");
1341 print "MT text A \n";
1342 print "MT fname $filename\n";
1343 print "MT newline\n";
1348 $log->info("UpdatingX3 '$filename' to ".$meta->{revision
});
1349 print "MT +updated\n";
1350 print "MT text U \n";
1351 print "MT fname $filename\n";
1352 print "MT newline\n";
1353 print "MT -updated\n";
1356 my ( $filepart, $dirpart ) = filenamesplit
($filename,1);
1358 # Don't want to actually _DO_ the update if -n specified
1359 unless ( $state->{globaloptions
}{-n
} )
1361 if ( defined ( $wrev ) )
1363 # instruct client we're sending a file to put in this path as a replacement
1364 print "Update-existing $dirpart\n";
1365 $log->debug("Updating existing file 'Update-existing $dirpart'");
1367 # instruct client we're sending a file to put in this path as a new file
1369 $log->debug("Creating new file 'Created $dirpart'");
1370 print "Created $dirpart\n";
1372 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1374 # this is an "entries" line
1375 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
1376 my $entriesLine = "/$filepart/$meta->{revision}//$kopts/";
1377 $entriesLine .= getStickyTagOrDate
($stickyInfo);
1378 $log->debug($entriesLine);
1379 print "$entriesLine\n";
1382 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1383 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1386 transmitfile
($meta->{filehash
});
1389 my ( $filepart, $dirpart ) = filenamesplit
($meta->{name
},1);
1391 my $mergeDir = setupTmpDir
();
1393 my $file_local = $filepart . ".mine";
1394 my $mergedFile = "$mergeDir/$file_local";
1395 system("ln","-s",$state->{entries
}{$filename}{modified_filename
}, $file_local);
1396 my $file_old = $filepart . "." . $oldmeta->{revision
};
1397 transmitfile
($oldmeta->{filehash
}, { targetfile
=> $file_old });
1398 my $file_new = $filepart . "." . $meta->{revision
};
1399 transmitfile
($meta->{filehash
}, { targetfile
=> $file_new });
1401 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
1402 $log->info("Merging $file_local, $file_old, $file_new");
1403 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
1405 $log->debug("Temporary directory for merge is $mergeDir");
1407 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
1414 $log->info("Merged successfully");
1415 print "M M $filename\n";
1416 $log->debug("Merged $dirpart");
1418 # Don't want to actually _DO_ the update if -n specified
1419 unless ( $state->{globaloptions
}{-n
} )
1421 print "Merged $dirpart\n";
1422 $log->debug($state->{CVSROOT
} . "/$state->{module}/$filename");
1423 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1424 my $kopts = kopts_from_path
("$dirpart/$filepart",
1425 "file",$mergedFile);
1426 $log->debug("/$filepart/$meta->{revision}//$kopts/");
1427 my $entriesLine="/$filepart/$meta->{revision}//$kopts/";
1428 $entriesLine .= getStickyTagOrDate
($stickyInfo);
1429 print "$entriesLine\n";
1432 elsif ( $return == 1 )
1434 $log->info("Merged with conflicts");
1435 print "E cvs update: conflicts found in $filename\n";
1436 print "M C $filename\n";
1438 # Don't want to actually _DO_ the update if -n specified
1439 unless ( $state->{globaloptions
}{-n
} )
1441 print "Merged $dirpart\n";
1442 print $state->{CVSROOT
} . "/$state->{module}/$filename\n";
1443 my $kopts = kopts_from_path
("$dirpart/$filepart",
1444 "file",$mergedFile);
1445 my $entriesLine = "/$filepart/$meta->{revision}/+/$kopts/";
1446 $entriesLine .= getStickyTagOrDate
($stickyInfo);
1447 print "$entriesLine\n";
1452 $log->warn("Merge failed");
1456 # Don't want to actually _DO_ the update if -n specified
1457 unless ( $state->{globaloptions
}{-n
} )
1460 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
1461 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
1463 # transmit file, format is single integer on a line by itself (file
1464 # size) followed by the file contents
1465 # TODO : we should copy files in blocks
1466 my $data = safe_pipe_capture
('cat', $mergedFile);
1467 $log->debug("File size : " . length($data));
1468 print length($data) . "\n";
1475 # prepDirForOutput() any other existing directories unless they already
1476 # have the right sticky tag:
1477 unless ( $state->{globaloptions
}{n
} )
1480 foreach $dir (keys(%{$state->{dirMap
}}))
1482 if( ! $seendirs{$dir} &&
1483 exists($state->{dirArgs
}{$dir}) )
1486 $oldTag=$state->{dirMap
}{$dir}{tagspec
};
1488 unless( ( exists($state->{opt
}{A
}) &&
1489 defined($oldTag) ) ||
1490 ( defined($state->{opt
}{r
}) &&
1491 ( !defined($oldTag) ||
1492 $state->{opt
}{r
} ne $oldTag ) ) )
1493 # TODO?: OR sticky dir is different...
1504 $state->{dirArgs
} );
1507 # TODO?: Consider sending a final duplicate Sticky response
1508 # to more closely mimic real CVS.
1517 my ( $cmd, $data ) = @_;
1521 #$log->debug("State : " . Dumper($state));
1523 $log->info("req_ci : " . ( defined($data) ?
$data : "[NULL]" ));
1525 if ( $state->{method
} eq 'pserver' and $state->{user
} eq 'anonymous' )
1527 print "error 1 anonymous user cannot commit via pserver\n";
1532 if ( -e
$state->{CVSROOT
} . "/index" )
1534 $log->warn("file 'index' already exists in the git repository");
1535 print "error 1 Index already exists in git repo\n";
1540 # Grab a handle to the SQLite db and do any necessary updates
1541 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1544 my @committedfiles = ();
1550 # foreach file specified on the command line ...
1551 foreach my $filename ( @
{$state->{args
}} )
1553 my $committedfile = $filename;
1554 $filename = filecleanup
($filename);
1556 next unless ( exists $state->{entries
}{$filename}{modified_filename
} or not $state->{entries
}{$filename}{unchanged
} );
1559 # Figure out which branch and parenthash we are committing
1560 # to, and setup worktree:
1562 # should always come from entries:
1563 my $fileStickyInfo = resolveStickyInfo
($filename);
1564 if( !defined($branchRef) )
1566 $stickyInfo = $fileStickyInfo;
1567 if( defined($stickyInfo) &&
1568 ( defined($stickyInfo->{date
}) ||
1569 !defined($stickyInfo->{tag
}) ) )
1571 print "error 1 cannot commit with sticky date for file `$filename'\n";
1576 $branchRef = "refs/heads/$state->{module}";
1577 if ( defined($stickyInfo) && defined($stickyInfo->{tag
}) )
1579 $branchRef = "refs/heads/$stickyInfo->{tag}";
1582 $parenthash = safe_pipe_capture
('git', 'show-ref', '-s', $branchRef);
1584 if ($parenthash !~ /^[0-9a-f]{40}$/)
1586 if ( defined($stickyInfo) && defined($stickyInfo->{tag
}) )
1588 print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n";
1592 print "error 1 pserver cannot find the current HEAD of module";
1598 setupWorkTree
($parenthash);
1600 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1602 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1604 elsif( !refHashEqual
($stickyInfo,$fileStickyInfo) )
1606 #TODO: We could split the cvs commit into multiple
1607 # git commits by distinct stickyTag values, but that
1608 # is lowish priority.
1609 print "error 1 Committing different files to different"
1610 . " branches is not currently supported\n";
1616 # Process this file:
1618 my $meta = $updater->getmeta($filename,$stickyInfo);
1619 $oldmeta{$filename} = $meta;
1621 my $wrev = revparse
($filename);
1623 my ( $filepart, $dirpart ) = filenamesplit
($filename);
1625 # do a checkout of the file if it is part of this tree
1627 system('git', 'checkout-index', '-f', '-u', $filename);
1629 die "Error running git-checkout-index -f -u $filename : $!";
1635 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
1636 $addflag = 1 unless ( -e
$filename );
1638 # Do up to date checking
1639 unless ( $addflag or $wrev eq $meta->{revision
} or
1640 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
1642 # fail everything if an up to date check fails
1643 print "error 1 Up to date check failed for $filename\n";
1648 push @committedfiles, $committedfile;
1649 $log->info("Committing $filename");
1651 system("mkdir","-p",$dirpart) unless ( -d
$dirpart );
1655 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1656 rename $state->{entries
}{$filename}{modified_filename
},$filename;
1658 # Calculate modes to remove
1660 foreach ( qw (r w x
) ) { $invmode .= $_ unless ( $state->{entries
}{$filename}{modified_mode
} =~ /$_/ ); }
1662 $log->debug("chmod u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode . " $filename");
1663 system("chmod","u+" . $state->{entries
}{$filename}{modified_mode
} . "-" . $invmode, $filename);
1668 $log->info("Removing file '$filename'");
1670 system("git", "update-index", "--remove", $filename);
1674 $log->info("Adding file '$filename'");
1675 system("git", "update-index", "--add", $filename);
1677 $log->info("UpdatingX2 file '$filename'");
1678 system("git", "update-index", $filename);
1682 unless ( scalar(@committedfiles) > 0 )
1684 print "E No files to commit\n";
1690 my $treehash = safe_pipe_capture
(qw(git
write-tree
));
1693 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1695 # write our commit message out if we have one ...
1696 my ( $msg_fh, $msg_filename ) = tempfile
( DIR
=> $TEMP_DIR );
1697 print $msg_fh $state->{opt
}{m
};# if ( exists ( $state->{opt}{m} ) );
1698 if ( defined ( $cfg->{gitcvs
}{commitmsgannotation
} ) ) {
1699 if ($cfg->{gitcvs
}{commitmsgannotation
} !~ /^\s*$/ ) {
1700 print $msg_fh "\n\n".$cfg->{gitcvs
}{commitmsgannotation
}."\n"
1703 print $msg_fh "\n\nvia git-CVS emulator\n";
1707 my $commithash = safe_pipe_capture
('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename);
1709 $log->info("Commit hash : $commithash");
1711 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1713 $log->warn("Commit failed (Invalid commit hash)");
1714 print "error 1 Commit failed (unknown reason)\n";
1719 ### Emulate git-receive-pack by running hooks/update
1720 my @hook = ( $ENV{GIT_DIR
}.'hooks/update', $branchRef,
1721 $parenthash, $commithash );
1723 unless( system( @hook ) == 0 )
1725 $log->warn("Commit failed (update hook declined to update ref)");
1726 print "error 1 Commit failed (update hook declined)\n";
1733 if (system(qw(git update
-ref -m
), "cvsserver ci",
1734 $branchRef, $commithash, $parenthash)) {
1735 $log->warn("update-ref for $state->{module} failed.");
1736 print "error 1 Cannot commit -- update first\n";
1741 ### Emulate git-receive-pack by running hooks/post-receive
1742 my $hook = $ENV{GIT_DIR
}.'hooks/post-receive';
1744 open(my $pipe, "| $hook") || die "can't fork $!";
1746 local $SIG{PIPE
} = sub { die 'pipe broke' };
1748 print $pipe "$parenthash $commithash $branchRef\n";
1750 close $pipe || die "bad pipe: $! $?";
1755 ### Then hooks/post-update
1756 $hook = $ENV{GIT_DIR
}.'hooks/post-update';
1758 system($hook, $branchRef);
1761 # foreach file specified on the command line ...
1762 foreach my $filename ( @committedfiles )
1764 $filename = filecleanup
($filename);
1766 my $meta = $updater->getmeta($filename,$stickyInfo);
1767 unless (defined $meta->{revision
}) {
1768 $meta->{revision
} = "1.1";
1771 my ( $filepart, $dirpart ) = filenamesplit
($filename, 1);
1773 $log->debug("Checked-in $dirpart : $filename");
1775 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
1776 if ( defined $meta->{filehash
} && $meta->{filehash
} eq "deleted" )
1778 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
1779 print "Remove-entry $dirpart\n";
1780 print "$filename\n";
1782 if ($meta->{revision
} eq "1.1") {
1783 print "M initial revision: 1.1\n";
1785 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
1787 print "Checked-in $dirpart\n";
1788 print "$filename\n";
1789 my $kopts = kopts_from_path
($filename,"sha1",$meta->{filehash
});
1790 print "/$filepart/$meta->{revision}//$kopts/" .
1791 getStickyTagOrDate
($stickyInfo) . "\n";
1801 my ( $cmd, $data ) = @_;
1805 $log->info("req_status : " . ( defined($data) ?
$data : "[NULL]" ));
1806 #$log->debug("status state : " . Dumper($state));
1808 # Grab a handle to the SQLite db and do any necessary updates
1810 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1813 # if no files were specified, we need to work out what files we should
1814 # be providing status on ...
1815 argsfromdir
($updater);
1817 # foreach file specified on the command line ...
1818 foreach my $filename ( @
{$state->{args
}} )
1820 $filename = filecleanup
($filename);
1822 if ( exists($state->{opt
}{l
}) &&
1823 index($filename, '/', length($state->{prependdir
})) >= 0 )
1828 my $wrev = revparse
($filename);
1830 my $stickyInfo = resolveStickyInfo
($filename);
1831 my $meta = $updater->getmeta($filename,$stickyInfo);
1832 my $oldmeta = $meta;
1834 # If the working copy is an old revision, lets get that
1835 # version too for comparison.
1836 if ( defined($wrev) and $wrev ne $meta->{revision
} )
1840 $oldmeta = $updater->getmeta($filename, $rmRev);
1843 # TODO : All possible statuses aren't yet implemented
1845 # Files are up to date if the working copy and repo copy have
1846 # the same revision, and the working copy is unmodified
1847 if ( defined ( $wrev ) and defined($meta->{revision
}) and
1848 $wrev eq $meta->{revision
} and
1849 ( ( $state->{entries
}{$filename}{unchanged
} and
1850 ( not defined ( $state->{entries
}{$filename}{conflict
} ) or
1851 $state->{entries
}{$filename}{conflict
} !~ /^\+=/ ) ) or
1852 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1853 $state->{entries
}{$filename}{modified_hash
} eq
1854 $meta->{filehash
} ) ) )
1856 $status = "Up-to-date"
1859 # Need checkout if the working copy has a different (usually
1860 # older) revision than the repo copy, and the working copy is
1862 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1863 $meta->{revision
} ne $wrev and
1864 ( $state->{entries
}{$filename}{unchanged
} or
1865 ( defined($state->{entries
}{$filename}{modified_hash
}) and
1866 $state->{entries
}{$filename}{modified_hash
} eq
1867 $oldmeta->{filehash
} ) ) )
1869 $status ||= "Needs Checkout";
1872 # Need checkout if it exists in the repo but doesn't have a working
1874 if ( not defined ( $wrev ) and defined ( $meta->{revision
} ) )
1876 $status ||= "Needs Checkout";
1879 # Locally modified if working copy and repo copy have the
1880 # same revision but there are local changes
1881 if ( defined ( $wrev ) and defined($meta->{revision
}) and
1882 $wrev eq $meta->{revision
} and
1884 $state->{entries
}{$filename}{modified_filename
} )
1886 $status ||= "Locally Modified";
1889 # Needs Merge if working copy revision is different
1890 # (usually older) than repo copy and there are local changes
1891 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1892 $meta->{revision
} ne $wrev and
1893 $state->{entries
}{$filename}{modified_filename
} )
1895 $status ||= "Needs Merge";
1898 if ( defined ( $state->{entries
}{$filename}{revision
} ) and
1899 ( !defined($meta->{revision
}) ||
1900 $meta->{revision
} eq "0" ) )
1902 $status ||= "Locally Added";
1904 if ( defined ( $wrev ) and defined ( $meta->{revision
} ) and
1905 $wrev eq "-$meta->{revision}" )
1907 $status ||= "Locally Removed";
1909 if ( defined ( $state->{entries
}{$filename}{conflict
} ) and
1910 $state->{entries
}{$filename}{conflict
} =~ /^\+=/ )
1912 $status ||= "Unresolved Conflict";
1916 $status ||= "File had conflicts on merge";
1919 $status ||= "Unknown";
1921 my ($filepart) = filenamesplit
($filename);
1923 print "M =======" . ( "=" x
60 ) . "\n";
1924 print "M File: $filepart\tStatus: $status\n";
1925 if ( defined($state->{entries
}{$filename}{revision
}) )
1927 print "M Working revision:\t" .
1928 $state->{entries
}{$filename}{revision
} . "\n";
1930 print "M Working revision:\tNo entry for $filename\n";
1932 if ( defined($meta->{revision
}) )
1934 print "M Repository revision:\t" .
1936 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
1937 my($tagOrDate)=$state->{entries
}{$filename}{tag_or_date
};
1938 my($tag)=($tagOrDate=~m/^T(.+)$/);
1939 if( !defined($tag) )
1943 print "M Sticky Tag:\t\t$tag\n";
1944 my($date)=($tagOrDate=~m/^D(.+)$/);
1945 if( !defined($date) )
1949 print "M Sticky Date:\t\t$date\n";
1950 my($options)=$state->{entries
}{$filename}{options
};
1951 if( $options eq "" )
1955 print "M Sticky Options:\t\t$options\n";
1957 print "M Repository revision:\tNo revision control file\n";
1967 my ( $cmd, $data ) = @_;
1971 $log->debug("req_diff : " . ( defined($data) ?
$data : "[NULL]" ));
1972 #$log->debug("status state : " . Dumper($state));
1974 my ($revision1, $revision2);
1975 if ( defined ( $state->{opt
}{r
} ) and ref $state->{opt
}{r
} eq "ARRAY" )
1977 $revision1 = $state->{opt
}{r
}[0];
1978 $revision2 = $state->{opt
}{r
}[1];
1980 $revision1 = $state->{opt
}{r
};
1983 $log->debug("Diffing revisions " .
1984 ( defined($revision1) ?
$revision1 : "[NULL]" ) .
1985 " and " . ( defined($revision2) ?
$revision2 : "[NULL]" ) );
1987 # Grab a handle to the SQLite db and do any necessary updates
1989 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
1992 # if no files were specified, we need to work out what files we should
1993 # be providing status on ...
1994 argsfromdir
($updater);
1998 # foreach file specified on the command line ...
1999 foreach my $argFilename ( @
{$state->{args
}} )
2001 my($filename) = filecleanup
($argFilename);
2003 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
2005 my $wrev = revparse
($filename);
2007 # Priority for revision1:
2008 # 1. First -r (missing file: check -N)
2009 # 2. wrev from client's Entry line
2010 # - missing line/file: check -N
2011 # - "0": added file not committed (empty contents for rev1)
2012 # - Prefixed with dash (to be removed): check -N
2014 if ( defined ( $revision1 ) )
2016 $meta1 = $updater->getmeta($filename, $revision1);
2018 elsif( defined($wrev) && $wrev ne "0" )
2022 $meta1 = $updater->getmeta($filename, $rmRev);
2024 if ( !defined($meta1) ||
2025 $meta1->{filehash
} eq "deleted" )
2027 if( !exists($state->{opt
}{N
}) )
2029 if(!defined($revision1))
2031 print "E File $filename at revision $revision1 doesn't exist\n";
2035 elsif( !defined($meta1) )
2040 filehash
=> 'deleted'
2045 # Priority for revision2:
2046 # 1. Second -r (missing file: check -N)
2047 # 2. Modified file contents from client
2048 # 3. wrev from client's Entry line
2049 # - missing line/file: check -N
2050 # - Prefixed with dash (to be removed): check -N
2052 # if we have a second -r switch, use it too
2053 if ( defined ( $revision2 ) )
2055 $meta2 = $updater->getmeta($filename, $revision2);
2057 elsif(defined($state->{entries
}{$filename}{modified_filename
}))
2059 $file2 = $state->{entries
}{$filename}{modified_filename
};
2063 filehash
=> 'modified'
2066 elsif( defined($wrev) && ($wrev!~/^-/) )
2068 if(!defined($revision1)) # no revision and no modifications:
2072 $meta2 = $updater->getmeta($filename, $wrev);
2074 if(!defined($file2))
2076 if ( !defined($meta2) ||
2077 $meta2->{filehash
} eq "deleted" )
2079 if( !exists($state->{opt
}{N
}) )
2081 if(!defined($revision2))
2083 print "E File $filename at revision $revision2 doesn't exist\n";
2087 elsif( !defined($meta2) )
2092 filehash
=> 'deleted'
2098 if( $meta1->{filehash
} eq $meta2->{filehash
} )
2100 $log->info("unchanged $filename");
2104 # Retrieve revision contents:
2105 ( undef, $file1 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
2106 transmitfile
($meta1->{filehash
}, { targetfile
=> $file1 });
2108 if(!defined($file2))
2110 ( undef, $file2 ) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
2111 transmitfile
($meta2->{filehash
}, { targetfile
=> $file2 });
2114 # Generate the actual diff:
2115 print "M Index: $argFilename\n";
2116 print "M =======" . ( "=" x
60 ) . "\n";
2117 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2118 if ( defined ( $meta1 ) && $meta1->{revision
} ne "0" )
2120 print "M retrieving revision $meta1->{revision}\n"
2122 if ( defined ( $meta2 ) && $meta2->{revision
} ne "0" )
2124 print "M retrieving revision $meta2->{revision}\n"
2127 foreach my $opt ( sort keys %{$state->{opt
}} )
2129 if ( ref $state->{opt
}{$opt} eq "ARRAY" )
2131 foreach my $value ( @
{$state->{opt
}{$opt}} )
2133 print "-$opt $value ";
2137 if ( defined ( $state->{opt
}{$opt} ) )
2139 print "$state->{opt}{$opt} "
2143 print "$argFilename\n";
2145 $log->info("Diffing $filename -r $meta1->{revision} -r " .
2146 ( $meta2->{revision
} or "workingcopy" ));
2148 # TODO: Use --label instead of -L because -L is no longer
2149 # documented and may go away someday. Not sure if there there are
2150 # versions that only support -L, which would make this change risky?
2151 # http://osdir.com/ml/bug-gnu-utils-gnu/2010-12/msg00060.html
2152 # ("man diff" should actually document the best migration strategy,
2153 # [current behavior, future changes, old compatibility issues
2154 # or lack thereof, etc], not just stop mentioning the option...)
2155 # TODO: Real CVS seems to include a date in the label, before
2156 # the revision part, without the keyword "revision". The following
2157 # has minimal changes compared to original versions of
2158 # git-cvsserver.perl. (Mostly tab vs space after filename.)
2160 my (@diffCmd) = ( 'diff' );
2161 if ( exists($state->{opt
}{N
}) )
2165 if ( exists $state->{opt
}{u
} )
2167 push @diffCmd,("-u","-L");
2168 if( $meta1->{filehash
} eq "deleted" )
2170 push @diffCmd,"/dev/null";
2172 push @diffCmd,("$argFilename\trevision $meta1->{revision}");
2175 if( defined($meta2->{filehash
}) )
2177 if( $meta2->{filehash
} eq "deleted" )
2179 push @diffCmd,("-L","/dev/null");
2181 push @diffCmd,("-L",
2182 "$argFilename\trevision $meta2->{revision}");
2185 push @diffCmd,("-L","$argFilename\tworking copy");
2188 push @diffCmd,($file1,$file2);
2189 if(!open(DIFF
,"-|",@diffCmd))
2191 $log->warn("Unable to run diff: $!");
2194 while(defined($diffLine=<DIFF
>))
2196 print "M $diffLine";
2214 my ( $cmd, $data ) = @_;
2218 $log->debug("req_log : " . ( defined($data) ?
$data : "[NULL]" ));
2219 #$log->debug("log state : " . Dumper($state));
2222 if ( defined ( $state->{opt
}{r
} ) )
2224 $revFilter = $state->{opt
}{r
};
2227 # Grab a handle to the SQLite db and do any necessary updates
2229 $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
2232 # if no files were specified, we need to work out what files we
2233 # should be providing status on ...
2234 argsfromdir
($updater);
2236 # foreach file specified on the command line ...
2237 foreach my $filename ( @
{$state->{args
}} )
2239 $filename = filecleanup
($filename);
2241 my $headmeta = $updater->getmeta($filename);
2243 my ($revisions,$totalrevisions) = $updater->getlog($filename,
2246 next unless ( scalar(@
$revisions) );
2249 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2250 print "M Working file: $filename\n";
2251 print "M head: $headmeta->{revision}\n";
2252 print "M branch:\n";
2253 print "M locks: strict\n";
2254 print "M access list:\n";
2255 print "M symbolic names:\n";
2256 print "M keyword substitution: kv\n";
2257 print "M total revisions: $totalrevisions;\tselected revisions: " .
2258 scalar(@
$revisions) . "\n";
2259 print "M description:\n";
2261 foreach my $revision ( @
$revisions )
2263 print "M ----------------------------\n";
2264 print "M revision $revision->{revision}\n";
2265 # reformat the date for log output
2266 if ( $revision->{modified
} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
2267 defined($DATE_LIST->{$2}) )
2269 $revision->{modified
} = sprintf('%04d/%02d/%02d %s',
2270 $3, $DATE_LIST->{$2}, $1, $4 );
2272 $revision->{author
} = cvs_author
($revision->{author
});
2273 print "M date: $revision->{modified};" .
2274 " author: $revision->{author}; state: " .
2275 ( $revision->{filehash
} eq "deleted" ?
"dead" : "Exp" ) .
2278 $commitmessage = $updater->commitmessage($revision->{commithash
});
2279 $commitmessage =~ s/^/M /mg;
2280 print $commitmessage . "\n";
2282 print "M =======" . ( "=" x
70 ) . "\n";
2290 my ( $cmd, $data ) = @_;
2292 argsplit
("annotate");
2294 $log->info("req_annotate : " . ( defined($data) ?
$data : "[NULL]" ));
2295 #$log->debug("status state : " . Dumper($state));
2297 # Grab a handle to the SQLite db and do any necessary updates
2298 my $updater = GITCVS
::updater
->new($state->{CVSROOT
}, $state->{module
}, $log);
2301 # if no files were specified, we need to work out what files we should be providing annotate on ...
2302 argsfromdir
($updater);
2304 # we'll need a temporary checkout dir
2307 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
2309 # foreach file specified on the command line ...
2310 foreach my $filename ( @
{$state->{args
}} )
2312 $filename = filecleanup
($filename);
2314 my $meta = $updater->getmeta($filename);
2316 next unless ( $meta->{revision
} );
2318 # get all the commits that this file was in
2319 # in dense format -- aka skip dead revisions
2320 my $revisions = $updater->gethistorydense($filename);
2321 my $lastseenin = $revisions->[0][2];
2323 # populate the temporary index based on the latest commit were we saw
2324 # the file -- but do it cheaply without checking out any files
2325 # TODO: if we got a revision from the client, use that instead
2326 # to look up the commithash in sqlite (still good to default to
2327 # the current head as we do now)
2328 system("git", "read-tree", $lastseenin);
2331 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
2334 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
2336 # do a checkout of the file
2337 system('git', 'checkout-index', '-f', '-u', $filename);
2339 print "E error running git-checkout-index -f -u $filename : $!\n";
2343 $log->info("Annotate $filename");
2345 # Prepare a file with the commits from the linearized
2346 # history that annotate should know about. This prevents
2347 # git-jsannotate telling us about commits we are hiding
2350 my $a_hints = "$work->{workDir}/.annotate_hints";
2351 if (!open(ANNOTATEHINTS
, '>', $a_hints)) {
2352 print "E failed to open '$a_hints' for writing: $!\n";
2355 for (my $i=0; $i < @
$revisions; $i++)
2357 print ANNOTATEHINTS
$revisions->[$i][2];
2358 if ($i+1 < @
$revisions) { # have we got a parent?
2359 print ANNOTATEHINTS
' ' . $revisions->[$i+1][2];
2361 print ANNOTATEHINTS
"\n";
2364 print ANNOTATEHINTS
"\n";
2366 or (print "E failed to write $a_hints: $!\n"), return;
2368 my @cmd = (qw(git annotate
-l
-S
), $a_hints, $filename);
2369 if (!open(ANNOTATE
, "-|", @cmd)) {
2370 print "E error invoking ". join(' ',@cmd) .": $!\n";
2374 print "E Annotations for $filename\n";
2375 print "E ***************\n";
2376 while ( <ANNOTATE
> )
2378 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
2380 my $commithash = $1;
2382 unless ( defined ( $metadata->{$commithash} ) )
2384 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
2385 $metadata->{$commithash}{author
} = cvs_author
($metadata->{$commithash}{author
});
2386 $metadata->{$commithash}{modified
} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified
} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2388 printf("M %-7s (%-8s %10s): %s\n",
2389 $metadata->{$commithash}{revision
},
2390 $metadata->{$commithash}{author
},
2391 $metadata->{$commithash}{modified
},
2395 $log->warn("Error in annotate output! LINE: $_");
2396 print "E Annotate error \n";
2403 # done; get out of the tempdir
2410 # This method takes the state->{arguments} array and produces two new arrays.
2411 # The first is $state->{args} which is everything before the '--' argument, and
2412 # the second is $state->{files} which is everything after it.
2415 $state->{args
} = [];
2416 $state->{files
} = [];
2419 return unless( defined($state->{arguments
}) and ref $state->{arguments
} eq "ARRAY" );
2423 if ( defined($type) )
2426 $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" );
2427 $opt = { v
=> 0, l
=> 0, R
=> 0 } if ( $type eq "status" );
2428 $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" );
2429 $opt = { l
=> 0, R
=> 0, k
=> 1, D
=> 1, D
=> 1, r
=> 2, N
=> 0 } if ( $type eq "diff" );
2430 $opt = { c
=> 0, R
=> 0, l
=> 0, f
=> 0, F
=> 1, m
=> 1, r
=> 1 } if ( $type eq "ci" );
2431 $opt = { k
=> 1, m
=> 1 } if ( $type eq "add" );
2432 $opt = { f
=> 0, l
=> 0, R
=> 0 } if ( $type eq "remove" );
2433 $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" );
2436 while ( scalar ( @
{$state->{arguments
}} ) > 0 )
2438 my $arg = shift @
{$state->{arguments
}};
2440 next if ( $arg eq "--" );
2441 next unless ( $arg =~ /\S/ );
2443 # if the argument looks like a switch
2444 if ( $arg =~ /^-(\w)(.*)/ )
2446 # if it's a switch that takes an argument
2449 # If this switch has already been provided
2450 if ( $opt->{$1} > 1 and exists ( $state->{opt
}{$1} ) )
2452 $state->{opt
}{$1} = [ $state->{opt
}{$1} ];
2453 if ( length($2) > 0 )
2455 push @
{$state->{opt
}{$1}},$2;
2457 push @
{$state->{opt
}{$1}}, shift @
{$state->{arguments
}};
2460 # if there's extra data in the arg, use that as the argument for the switch
2461 if ( length($2) > 0 )
2463 $state->{opt
}{$1} = $2;
2465 $state->{opt
}{$1} = shift @
{$state->{arguments
}};
2469 $state->{opt
}{$1} = undef;
2474 push @
{$state->{args
}}, $arg;
2482 foreach my $value ( @
{$state->{arguments
}} )
2484 if ( $value eq "--" )
2489 push @
{$state->{args
}}, $value if ( $mode == 0 );
2490 push @
{$state->{files
}}, $value if ( $mode == 1 );
2495 # Used by argsfromdir
2498 my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_;
2500 my $fullPath = filecleanup
($path);
2502 # Is it a directory?
2503 if( defined($state->{dirMap
}{$fullPath}) ||
2504 defined($state->{dirMap
}{"$fullPath/"}) )
2506 # It is a directory in the user's sandbox.
2509 if(defined($state->{entries
}{$fullPath}))
2511 $log->fatal("Inconsistent file/dir type");
2512 die "Inconsistent file/dir type";
2515 elsif(defined($state->{entries
}{$fullPath}))
2517 # It is a file in the user's sandbox.
2520 my($revDirMap,$otherRevDirMap);
2521 if(!defined($isDir) || $isDir)
2523 # Resolve version tree for sticky tag:
2524 # (for now we only want list of files for the version, not
2525 # particular versions of those files: assume it is a directory
2526 # for the moment; ignore Entry's stick tag)
2528 # Order of precedence of sticky tags:
2531 # [file entry sticky tag, but that is only relevant to files]
2532 # [the tag specified in dir req_Sticky]
2533 # [the tag specified in a parent dir req_Sticky]
2535 # Also, -r may appear twice (for diff).
2537 # FUTURE: When/if -j (merges) are supported, we also
2538 # need to add relevant files from one or two
2539 # versions specified with -j.
2541 if(exists($state->{opt
}{A
}))
2543 $revDirMap=$updater->getRevisionDirMap();
2545 elsif( defined($state->{opt
}{r
}) and
2546 ref $state->{opt
}{r
} eq "ARRAY" )
2548 $revDirMap=$updater->getRevisionDirMap($state->{opt
}{r
}[0]);
2549 $otherRevDirMap=$updater->getRevisionDirMap($state->{opt
}{r
}[1]);
2551 elsif(defined($state->{opt
}{r
}))
2553 $revDirMap=$updater->getRevisionDirMap($state->{opt
}{r
});
2557 my($sticky)=getDirStickyInfo
($fullPath);
2558 $revDirMap=$updater->getRevisionDirMap($sticky->{tag
});
2561 # Is it a directory?
2562 if( defined($revDirMap->{$fullPath}) ||
2563 defined($otherRevDirMap->{$fullPath}) )
2569 # What to do with it?
2572 $outNameMap->{$fullPath}=1;
2576 $outDirMap->{$fullPath}=1;
2578 if(defined($revDirMap->{$fullPath}))
2580 addDirMapFiles
($updater,$outNameMap,$outDirMap,
2581 $revDirMap->{$fullPath});
2583 if( defined($otherRevDirMap) &&
2584 defined($otherRevDirMap->{$fullPath}) )
2586 addDirMapFiles
($updater,$outNameMap,$outDirMap,
2587 $otherRevDirMap->{$fullPath});
2592 # Used by argsfromdir
2593 # Add entries from dirMap to outNameMap. Also recurse into entries
2594 # that are subdirectories.
2597 my($updater,$outNameMap,$outDirMap,$dirMap)=@_;
2600 foreach $fullName (keys(%$dirMap))
2602 my $cleanName=$fullName;
2603 if(defined($state->{prependdir
}))
2605 if(!($cleanName=~s/^\Q$state->{prependdir}\E//))
2607 $log->fatal("internal error stripping prependdir");
2608 die "internal error stripping prependdir";
2612 if($dirMap->{$fullName} eq "F")
2614 $outNameMap->{$cleanName}=1;
2616 elsif($dirMap->{$fullName} eq "D")
2618 if(!$state->{opt
}{l
})
2620 expandArg
($updater,$outNameMap,$outDirMap,$cleanName,1);
2625 $log->fatal("internal error in addDirMapFiles");
2626 die "internal error in addDirMapFiles";
2631 # This method replaces $state->{args} with a directory-expanded
2632 # list of all relevant filenames (recursively unless -d), based
2633 # on $state->{entries}, and the "current" list of files in
2634 # each directory. "Current" files as determined by
2635 # either the requested (-r/-A) or "req_Sticky" version of
2637 # Both the input args and the new output args are relative
2638 # to the cvs-client's CWD, although some of the internal
2639 # computations are relative to the top of the project.
2642 my $updater = shift;
2644 # Notes about requirements for specific callers:
2645 # update # "standard" case (entries; a single -r/-A/default; -l)
2646 # # Special case: -d for create missing directories.
2647 # diff # 0 or 1 -r's: "standard" case.
2648 # # 2 -r's: We could ignore entries (just use the two -r's),
2649 # # but it doesn't really matter.
2650 # annotate # "standard" case
2651 # log # Punting: log -r has a more complex non-"standard"
2652 # # meaning, and we don't currently try to support log'ing
2653 # # branches at all (need a lot of work to
2654 # # support CVS-consistent branch relative version
2656 #HERE: But we still want to expand directories. Maybe we should
2657 # essentially force "-A".
2658 # status # "standard", except that -r/-A/default are not possible.
2659 # # Mostly only used to expand entries only)
2661 # Don't use argsfromdir at all:
2662 # add # Explicit arguments required. Directory args imply add
2663 # # the directory itself, not the files in it.
2664 # co # Obtain list directly.
2665 # remove # HERE: TEST: MAYBE client does the recursion for us,
2666 # # since it only makes sense to remove stuff already in
2668 # ci # HERE: Similar to remove...
2669 # # Don't try to implement the confusing/weird
2670 # # ci -r bug er.."feature".
2672 if(scalar(@
{$state->{args
}})==0)
2674 $state->{args
} = [ "." ];
2678 for my $file (@
{$state->{args
}})
2680 expandArg
($updater,\
%allArgs,\
%allDirs,$file);
2683 # Include any entries from sandbox. Generally client won't
2684 # send entries that shouldn't be used.
2685 foreach my $file (keys %{$state->{entries
}})
2687 $allArgs{remove_prependdir
($file)} = 1;
2690 $state->{dirArgs
} = \
%allDirs;
2693 # Sort priority: by directory depth, then actual file name:
2694 my @piecesA=split('/',$a);
2695 my @piecesB=split('/',$b);
2697 my $count=scalar(@piecesA);
2698 my $tmp=scalar(@piecesB);
2699 return $count<=>$tmp if($count!=$tmp);
2701 for($tmp=0;$tmp<$count;$tmp++)
2703 if($piecesA[$tmp] ne $piecesB[$tmp])
2705 return $piecesA[$tmp] cmp $piecesB[$tmp]
2712 ## look up directory sticky tag, of either fullPath or a parent:
2713 sub getDirStickyInfo
2718 while($fullPath ne "" && !defined($state->{dirMap
}{"$fullPath/"}))
2720 $fullPath=~s
%/?[^/]*$%%;
2723 if( !defined($state->{dirMap
}{"$fullPath/"}) &&
2724 ( $fullPath eq "" ||
2725 $fullPath eq "." ) )
2727 return $state->{dirMap
}{""}{stickyInfo
};
2731 return $state->{dirMap
}{"$fullPath/"}{stickyInfo
};
2735 # Resolve precedence of various ways of specifying which version of
2736 # a file you want. Returns undef (for default head), or a ref to a hash
2737 # that contains "tag" and/or "date" keys.
2738 sub resolveStickyInfo
2740 my($filename,$stickyTag,$stickyDate,$reset) = @_;
2742 # Order of precedence of sticky tags:
2745 # [file entry sticky tag]
2746 # [the tag specified in dir req_Sticky]
2747 # [the tag specified in a parent dir req_Sticky]
2755 elsif( defined($stickyTag) && $stickyTag ne "" )
2756 # || ( defined($stickyDate) && $stickyDate ne "" ) # TODO
2758 $result={ 'tag' => (defined($stickyTag)?
$stickyTag:undef) };
2760 # TODO: Convert -D value into the form 2011.04.10.04.46.57,
2761 # similar to an entry line's sticky date, without the D prefix.
2762 # It sometimes (always?) arrives as something more like
2763 # '10 Apr 2011 04:46:57 -0000'...
2764 # $result={ 'date' => (defined($stickyDate)?$stickyDate:undef) };
2766 elsif( defined($state->{entries
}{$filename}) &&
2767 defined($state->{entries
}{$filename}{tag_or_date
}) &&
2768 $state->{entries
}{$filename}{tag_or_date
} ne "" )
2770 my($tagOrDate)=$state->{entries
}{$filename}{tag_or_date
};
2771 if($tagOrDate=~/^T([^ ]+)\s*$/)
2773 $result = { 'tag' => $1 };
2775 elsif($tagOrDate=~/^D([0-9.]+)\s*$/)
2777 $result= { 'date' => $1 };
2781 die "Unknown tag_or_date format\n";
2786 $result=getDirStickyInfo
($filename);
2792 # Convert a stickyInfo (ref to a hash) as returned by resolveStickyInfo into
2793 # a form appropriate for the sticky tag field of an Entries
2794 # line (field index 5, 0-based).
2795 sub getStickyTagOrDate
2800 if(defined($stickyInfo) && defined($stickyInfo->{tag
}))
2802 $result="T$stickyInfo->{tag}";
2804 # TODO: When/if we actually pick versions by {date} properly,
2805 # also handle it here:
2806 # "D$stickyInfo->{date}" (example: "D2011.04.13.20.37.07").
2815 # This method cleans up the $state variable after a command that uses arguments has run
2818 $state->{files
} = [];
2819 $state->{dirArgs
} = {};
2820 $state->{args
} = [];
2821 $state->{arguments
} = [];
2822 $state->{entries
} = {};
2823 $state->{dirMap
} = {};
2826 # Return working directory CVS revision "1.X" out
2827 # of the working directory "entries" state, for the given filename.
2828 # This is prefixed with a dash if the file is scheduled for removal
2829 # when it is committed.
2832 my $filename = shift;
2834 return $state->{entries
}{$filename}{revision
};
2837 # This method takes a file hash and does a CVS "file transfer". Its
2838 # exact behaviour depends on a second, optional hash table argument:
2839 # - If $options->{targetfile}, dump the contents to that file;
2840 # - If $options->{print}, use M/MT to transmit the contents one line
2842 # - Otherwise, transmit the size of the file, followed by the file
2846 my $filehash = shift;
2847 my $options = shift;
2849 if ( defined ( $filehash ) and $filehash eq "deleted" )
2851 $log->warn("filehash is 'deleted'");
2855 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2857 my $type = safe_pipe_capture
('git', 'cat-file', '-t', $filehash);
2860 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2862 my $size = safe_pipe_capture
('git', 'cat-file', '-s', $filehash);
2865 $log->debug("transmitfile($filehash) size=$size, type=$type");
2867 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
2869 if ( defined ( $options->{targetfile
} ) )
2871 my $targetfile = $options->{targetfile
};
2872 open NEWFILE
, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2873 print NEWFILE
$_ while ( <$fh> );
2874 close NEWFILE
or die("Failed to write '$targetfile': $!");
2875 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2880 print 'MT text ', $_, "\n";
2885 print while ( <$fh> );
2887 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
2889 die("Couldn't execute git-cat-file");
2893 # This method takes a file name, and returns ( $dirpart, $filepart ) which
2894 # refers to the directory portion and the file portion of the filename
2898 my $filename = shift;
2899 my $fixforlocaldir = shift;
2901 my ( $filepart, $dirpart ) = ( $filename, "." );
2902 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2905 if ( $fixforlocaldir )
2907 $dirpart =~ s/^$state->{prependdir}//;
2910 return ( $filepart, $dirpart );
2913 # Cleanup various junk in filename (try to canonicalize it), and
2914 # add prependdir to accommodate running CVS client from a
2915 # subdirectory (so the output is relative to top directory of the project).
2918 my $filename = shift;
2920 return undef unless(defined($filename));
2921 if ( $filename =~ /^\// )
2923 print "E absolute filenames '$filename' not supported by server\n";
2927 if($filename eq ".")
2931 $filename =~ s/^\.\///g
;
2932 $filename =~ s
%/+%/%g;
2933 $filename = $state->{prependdir
} . $filename;
2934 $filename =~ s
%/$%%;
2938 # Remove prependdir from the path, so that it is relative to the directory
2939 # the CVS client was started from, rather than the top of the project.
2940 # Essentially the inverse of filecleanup().
2941 sub remove_prependdir
2944 if(defined($state->{prependdir
}) && $state->{prependdir
} ne "")
2946 my($pre)=$state->{prependdir
};
2948 if(!($path=~s
%^\Q
$pre\E
/?
%%))
2950 $log->fatal("internal error missing prependdir");
2951 die("internal error missing prependdir");
2959 if( !defined($state->{CVSROOT
}) )
2961 print "error 1 CVSROOT not specified\n";
2965 if( $ENV{GIT_DIR
} ne ($state->{CVSROOT
} . '/') )
2967 print "error 1 Internally inconsistent CVSROOT\n";
2973 # Setup working directory in a work tree with the requested version
2974 # loaded in the index.
2981 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2982 defined($work->{tmpDir
}) )
2984 $log->warn("Bad work tree state management");
2985 print "error 1 Internal setup multiple work trees without cleanup\n";
2990 $work->{workDir
} = tempdir
( DIR
=> $TEMP_DIR );
2992 if( !defined($work->{index}) )
2994 (undef, $work->{index}) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
2997 chdir $work->{workDir
} or
2998 die "Unable to chdir to $work->{workDir}\n";
3000 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
3002 $ENV{GIT_WORK_TREE
} = ".";
3003 $ENV{GIT_INDEX_FILE
} = $work->{index};
3008 system("git","read-tree",$ver);
3011 $log->warn("Error running git-read-tree");
3012 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
3015 # else # req_annotate reads tree for each file
3018 # Ensure current directory is in some kind of working directory,
3019 # with a recent version loaded in the index.
3022 if( defined($work->{tmpDir
}) )
3024 $log->warn("Bad work tree state management [ensureWorkTree()]");
3025 print "error 1 Internal setup multiple dirs without cleanup\n";
3029 if( $work->{state} )
3036 if( !defined($work->{emptyDir
}) )
3038 $work->{emptyDir
} = tempdir
( DIR
=> $TEMP_DIR, OPEN
=> 0);
3040 chdir $work->{emptyDir
} or
3041 die "Unable to chdir to $work->{emptyDir}\n";
3043 my $ver = safe_pipe_capture
('git', 'show-ref', '-s', "refs/heads/$state->{module}");
3045 if ($ver !~ /^[0-9a-f]{40}$/)
3047 $log->warn("Error from git show-ref -s refs/head$state->{module}");
3048 print "error 1 cannot find the current HEAD of module";
3053 if( !defined($work->{index}) )
3055 (undef, $work->{index}) = tempfile
( DIR
=> $TEMP_DIR, OPEN
=> 0 );
3058 $ENV{GIT_WORK_TREE
} = ".";
3059 $ENV{GIT_INDEX_FILE
} = $work->{index};
3062 system("git","read-tree",$ver);
3065 die "Error running git-read-tree $ver $!\n";
3069 # Cleanup working directory that is not needed any longer.
3072 if( ! $work->{state} )
3077 chdir "/" or die "Unable to chdir '/'\n";
3079 if( defined($work->{workDir
}) )
3081 rmtree
( $work->{workDir
} );
3082 undef $work->{workDir
};
3084 undef $work->{state};
3087 # Setup a temporary directory (not a working tree), typically for
3088 # merging dirty state as in req_update.
3091 $work->{tmpDir
} = tempdir
( DIR
=> $TEMP_DIR );
3092 chdir $work->{tmpDir
} or die "Unable to chdir $work->{tmpDir}\n";
3094 return $work->{tmpDir
};
3097 # Clean up a previously setupTmpDir. Restore previous work tree if
3101 if ( !defined($work->{tmpDir
}) )
3103 $log->warn("cleanup tmpdir that has not been setup");
3104 die "Cleanup tmpDir that has not been setup\n";
3106 if( defined($work->{state}) )
3108 if( $work->{state} == 1 )
3110 chdir $work->{emptyDir
} or
3111 die "Unable to chdir to $work->{emptyDir}\n";
3113 elsif( $work->{state} == 2 )
3115 chdir $work->{workDir
} or
3116 die "Unable to chdir to $work->{emptyDir}\n";
3120 $log->warn("Inconsistent work dir state");
3121 die "Inconsistent work dir state\n";
3126 chdir "/" or die "Unable to chdir '/'\n";
3130 # Given a path, this function returns a string containing the kopts
3131 # that should go into that path's Entries line. For example, a binary
3132 # file should get -kb.
3135 my ($path, $srcType, $name) = @_;
3137 if ( defined ( $cfg->{gitcvs
}{usecrlfattr
} ) and
3138 $cfg->{gitcvs
}{usecrlfattr
} =~ /\s*(1|true|yes)\s*$/i )
3140 my ($val) = check_attr
( "text", $path );
3141 if ( $val eq "unspecified" )
3143 $val = check_attr
( "crlf", $path );
3145 if ( $val eq "unset" )
3149 elsif ( check_attr
( "eol", $path ) ne "unspecified" ||
3150 $val eq "set" || $val eq "input" )
3156 $log->info("Unrecognized check_attr crlf $path : $val");
3160 if ( defined ( $cfg->{gitcvs
}{allbinary
} ) )
3162 if( ($cfg->{gitcvs
}{allbinary
} =~ /^\s*(1|true|yes)\s*$/i) )
3166 elsif( ($cfg->{gitcvs
}{allbinary
} =~ /^\s*guess\s*$/i) )
3168 if( is_binary
($srcType,$name) )
3170 $log->debug("... as binary");
3175 $log->debug("... as text");
3179 # Return "" to give no special treatment to any path
3185 my ($attr,$path) = @_;
3187 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
3191 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
3200 # This should have the same heuristics as convert.c:is_binary() and related.
3201 # Note that the bare CR test is done by callers in convert.c.
3204 my ($srcType,$name) = @_;
3205 $log->debug("is_binary($srcType,$name)");
3207 # Minimize amount of interpreted code run in the inner per-character
3208 # loop for large files, by totalling each character value and
3209 # then analyzing the totals.
3212 for($i=0;$i<256;$i++)
3217 my $fh = open_blob_or_die
($srcType,$name);
3219 while( defined($line=<$fh>) )
3221 # Any '\0' and bare CR are considered binary.
3222 if( $line =~ /\0|(\r[^\n])/ )
3228 # Count up each character in the line:
3229 my $len=length($line);
3230 for($i=0;$i<$len;$i++)
3232 $counts[ord(substr($line,$i,1))]++;
3237 # Don't count CR and LF as either printable/nonprintable
3238 $counts[ord("\n")]=0;
3239 $counts[ord("\r")]=0;
3241 # Categorize individual character count into printable and nonprintable:
3244 for($i=0;$i<256;$i++)
3252 $nonprintable+=$counts[$i];
3254 elsif( $i==127 ) # DEL
3256 $nonprintable+=$counts[$i];
3260 $printable+=$counts[$i];
3264 return ($printable >> 7) < $nonprintable;
3267 # Returns open file handle. Possible invocations:
3268 # - open_blob_or_die("file",$filename);
3269 # - open_blob_or_die("sha1",$filehash);
3270 sub open_blob_or_die
3272 my ($srcType,$name) = @_;
3274 if( $srcType eq "file" )
3276 if( !open $fh,"<",$name )
3278 $log->warn("Unable to open file $name: $!");
3279 die "Unable to open file $name: $!\n";
3282 elsif( $srcType eq "sha1" )
3284 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
3286 $log->warn("Need filehash");
3287 die "Need filehash\n";
3290 my $type = safe_pipe_capture
('git', 'cat-file', '-t', $name);
3293 unless ( defined ( $type ) and $type eq "blob" )
3295 $log->warn("Invalid type '$type' for '$name'");
3296 die ( "Invalid type '$type' (expected 'blob')" )
3299 my $size = safe_pipe_capture
('git', 'cat-file', '-s', $name);
3302 $log->debug("open_blob_or_die($name) size=$size, type=$type");
3304 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
3306 $log->warn("Unable to open sha1 $name");
3307 die "Unable to open sha1 $name\n";
3312 $log->warn("Unknown type of blob source: $srcType");
3313 die "Unknown type of blob source: $srcType\n";
3318 # Generate a CVS author name from Git author information, by taking the local
3319 # part of the email address and replacing characters not in the Portable
3320 # Filename Character Set (see IEEE Std 1003.1-2001, 3.276) by underscores. CVS
3321 # Login names are Unix login names, which should be restricted to this
3325 my $author_line = shift;
3326 (my $author) = $author_line =~ /<([^@>]*)/;
3328 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
3337 # This table is from src/scramble.c in the CVS source
3339 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
3340 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
3341 114,120, 53, 79, 96,109, 72,108, 70, 64, 76, 67,116, 74, 68, 87,
3342 111, 52, 75,119, 49, 34, 82, 81, 95, 65,112, 86,118,110,122,105,
3343 41, 57, 83, 43, 46,102, 40, 89, 38,103, 45, 50, 42,123, 91, 35,
3344 125, 55, 54, 66,124,126, 59, 47, 92, 71,115, 78, 88,107,106, 56,
3345 36,121,117,104,101,100, 69, 73, 99, 63, 94, 93, 39, 37, 61, 48,
3346 58,113, 32, 90, 44, 98, 60, 51, 33, 97, 62, 77, 84, 80, 85,223,
3347 225,216,187,166,229,189,222,188,141,249,148,200,184,136,248,190,
3348 199,170,181,204,138,232,218,183,255,234,220,247,213,203,226,193,
3349 174,172,228,252,217,201,131,230,197,211,145,238,161,179,160,212,
3350 207,221,254,173,202,146,224,151,140,196,205,130,135,133,143,246,
3351 192,159,244,239,185,168,215,144,139,165,180,157,147,186,214,176,
3352 227,231,219,169,175,156,206,198,129,164,150,210,154,177,134,127,
3353 182,128,158,208,162,132,167,209,149,241,153,251,237,236,171,195,
3354 243,233,253,240,194,250,191,155,142,137,245,235,163,242,178,152
3358 # This should never happen, the same password format (A) has been
3359 # used by CVS since the beginning of time
3361 my $fmt = substr($str, 0, 1);
3362 die "invalid password format `$fmt'" unless $fmt eq 'A';
3365 my @str = unpack "C*", substr($str, 1);
3366 my $ret = join '', map { chr $SHIFTS[$_] } @str;
3370 # Test if the (deep) values of two references to a hash are the same.
3383 elsif( !defined($v2) ||
3384 scalar(keys(%{$v1})) != scalar(keys(%{$v2})) )
3393 foreach $key (keys(%{$v1}))
3395 if( !exists($v2->{$key}) ||
3396 defined($v1->{$key}) ne defined($v2->{$key}) ||
3397 ( defined($v1->{$key}) &&
3398 $v1->{$key} ne $v2->{$key} ) )
3409 # an alternative to `command` that allows input to be passed as an array
3410 # to work around shell problems with weird characters in arguments
3412 sub safe_pipe_capture
{
3416 if (my $pid = open my $child, '-|') {
3417 @output = (<$child>);
3418 close $child or die join(' ',@_).": $! $?";
3420 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3422 return wantarray ?
@output : join('',@output);
3426 package GITCVS
::log;
3429 #### Copyright The Open University UK - 2006.
3431 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
3432 #### Martin Langhoff <martin@laptop.org>
3445 This module provides very crude logging with a similar interface to
3454 Creates a new log object, optionally you can specify a filename here to
3455 indicate the file to log to. If no log file is specified, you can specify one
3456 later with method setfile, or indicate you no longer want logging with method
3459 Until one of these methods is called, all log calls will buffer messages ready
3466 my $filename = shift;
3470 bless $self, $class;
3472 if ( defined ( $filename ) )
3474 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3482 This methods takes a filename, and attempts to open that file as the log file.
3483 If successful, all buffered data is written out to the file, and any further
3484 logging is written directly to the file.
3490 my $filename = shift;
3492 if ( defined ( $filename ) )
3494 open $self->{fh
}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3497 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
3499 while ( my $line = shift @
{$self->{buffer
}} )
3501 print {$self->{fh
}} $line;
3507 This method indicates no logging is going to be used. It flushes any entries in
3508 the internal buffer, and sets a flag to ensure no further data is put there.
3517 return unless ( defined ( $self->{buffer
} ) and ref $self->{buffer
} eq "ARRAY" );
3519 $self->{buffer
} = [];
3524 Internal method. Returns true if the log file is open, false otherwise.
3531 return 1 if ( defined ( $self->{fh
} ) and ref $self->{fh
} eq "GLOB" );
3535 =head2 debug info warn fatal
3537 These four methods are wrappers to _log. They provide the actual interface for
3541 sub debug
{ my $self = shift; $self->_log("debug", @_); }
3542 sub info
{ my $self = shift; $self->_log("info&