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.
22 use File::Temp qw/tempdir tempfile/;
25 my $log = GITCVS::log->new();
43 # Enable autoflush for STDOUT (otherwise the whole thing falls apart)
46 #### Definition and mappings of functions ####
50 'Valid-responses' => \&req_Validresponses,
51 'valid-requests' => \&req_validrequests,
52 'Directory' => \&req_Directory,
53 'Entry' => \&req_Entry,
54 'Modified' => \&req_Modified,
55 'Unchanged' => \&req_Unchanged,
56 'Questionable' => \&req_Questionable,
57 'Argument' => \&req_Argument,
58 'Argumentx' => \&req_Argument,
59 'expand-modules' => \&req_expandmodules,
61 'remove' => \&req_remove,
63 'update' => \&req_update,
68 'tag' => \&req_CATCHALL,
69 'status' => \&req_status,
70 'admin' => \&req_CATCHALL,
71 'history' => \&req_CATCHALL,
72 'watchers' => \&req_CATCHALL,
73 'editors' => \&req_CATCHALL,
74 'annotate' => \&req_annotate,
75 'Global_option' => \&req_Globaloption,
76 #'annotate' => \&req_CATCHALL,
79 ##############################################
82 # $state holds all the bits of information the clients sends us that could
83 # potentially be useful when it comes to actually _doing_ something.
85 $log->info("--------------- STARTING -----------------");
87 my $TEMP_DIR = tempdir( CLEANUP => 1 );
88 $log->debug("Temporary directory is '$TEMP_DIR'");
90 # Keep going until the client closes the connection
95 # Check to see if we've seen this method, and call appropiate function.
96 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
98 # use the $methods hash to call the appropriate sub for this command
99 #$log->info("Method : $1");
100 &{$methods->{$1}}($1,$2);
102 # log fatal because we don't understand this function. If this happens
103 # we're fairly screwed because we don't know if the client is expecting
104 # a response. If it is, the client will hang, we'll hang, and the whole
105 # thing will be custard.
106 $log->fatal("Don't understand command $_\n");
107 die("Unknown command $_");
111 $log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
112 $log->info("--------------- FINISH -----------------");
114 # Magic catchall method.
115 # This is the method that will handle all commands we haven't yet
116 # implemented. It simply sends a warning to the log file indicating a
117 # command that hasn't been implemented has been invoked.
120 my ( $cmd, $data ) = @_;
121 $log->warn("Unhandled command : req_$cmd : $data");
126 # Response expected: no. Tell the server which CVSROOT to use. Note that
127 # pathname is a local directory and not a fully qualified CVSROOT variable.
128 # pathname must already exist; if creating a new root, use the init
129 # request, not Root. pathname does not include the hostname of the server,
130 # how to access the server, etc.; by the time the CVS protocol is in use,
131 # connection, authentication, etc., are already taken care of. The Root
132 # request must be sent only once, and it must be sent before any requests
133 # other than Valid-responses, valid-requests, UseUnchanged, Set or init.
136 my ( $cmd, $data ) = @_;
137 $log->debug("req_Root : $data");
139 $state->{CVSROOT} = $data;
141 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
142 unless (-d $ENV{GIT_DIR} && -e $ENV{GIT_DIR}.'HEAD') {
143 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
145 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
149 my @gitvars = `git-var -l`;
151 print "E problems executing git-var on the server -- this is not a git repository or the PATH is not set correcly.\n";
153 print "error 1 - problem executing git-var\n";
156 foreach my $line ( @gitvars )
158 next unless ( $line =~ /^(.*?)\.(.*?)=(.*)$/ );
162 unless ( defined ( $cfg->{gitcvs}{enabled} ) and $cfg->{gitcvs}{enabled} =~ /^\s*(1|true|yes)\s*$/i )
164 print "E GITCVS emulation needs to be enabled on this repo\n";
165 print "E the repo config file needs a [gitcvs] section added, and the parameter 'enabled' set to 1\n";
167 print "error 1 GITCVS emulation disabled\n";
170 if ( defined ( $cfg->{gitcvs}{logfile} ) )
172 $log->setfile($cfg->{gitcvs}{logfile});
178 # Global_option option \n
179 # Response expected: no. Transmit one of the global options `-q', `-Q',
180 # `-l', `-t', `-r', or `-n'. option must be one of those strings, no
181 # variations (such as combining of options) are allowed. For graceful
182 # handling of valid-requests, it is probably better to make new global
183 # options separate requests, rather than trying to add them to this
187 my ( $cmd, $data ) = @_;
188 $log->debug("req_Globaloption : $data");
190 # TODO : is this data useful ???
193 # Valid-responses request-list \n
194 # Response expected: no. Tell the server what responses the client will
195 # accept. request-list is a space separated list of tokens.
196 sub req_Validresponses
198 my ( $cmd, $data ) = @_;
199 $log->debug("req_Validrepsonses : $data");
201 # TODO : re-enable this, currently it's not particularly useful
202 #$state->{validresponses} = [ split /\s+/, $data ];
206 # Response expected: yes. Ask the server to send back a Valid-requests
208 sub req_validrequests
210 my ( $cmd, $data ) = @_;
212 $log->debug("req_validrequests");
214 $log->debug("SEND : Valid-requests " . join(" ",keys %$methods));
215 $log->debug("SEND : ok");
217 print "Valid-requests " . join(" ",keys %$methods) . "\n";
221 # Directory local-directory \n
222 # Additional data: repository \n. Response expected: no. Tell the server
223 # what directory to use. The repository should be a directory name from a
224 # previous server response. Note that this both gives a default for Entry
225 # and Modified and also for ci and the other commands; normal usage is to
226 # send Directory for each directory in which there will be an Entry or
227 # Modified, and then a final Directory for the original directory, then the
228 # command. The local-directory is relative to the top level at which the
229 # command is occurring (i.e. the last Directory which is sent before the
230 # command); to indicate that top level, `.' should be sent for
234 my ( $cmd, $data ) = @_;
236 my $repository = <STDIN>;
240 $state->{localdir} = $data;
241 $state->{repository} = $repository;
242 $state->{directory} = $repository;
243 $state->{directory} =~ s/^$state->{CVSROOT}\///;
244 $state->{module} = $1 if ($state->{directory} =~ s/^(.*?)(\/|$)//);
245 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
247 $log->debug("req_Directory : localdir=$data repository=$repository directory=$state->{directory} module=$state->{module}");
250 # Entry entry-line \n
251 # Response expected: no. Tell the server what version of a file is on the
252 # local machine. The name in entry-line is a name relative to the directory
253 # most recently specified with Directory. If the user is operating on only
254 # some files in a directory, Entry requests for only those files need be
255 # included. If an Entry request is sent without Modified, Is-modified, or
256 # Unchanged, it means the file is lost (does not exist in the working
257 # directory). If both Entry and one of Modified, Is-modified, or Unchanged
258 # are sent for the same file, Entry must be sent first. For a given file,
259 # one can send Modified, Is-modified, or Unchanged, but not more than one
263 my ( $cmd, $data ) = @_;
265 $log->debug("req_Entry : $data");
267 my @data = split(/\//, $data);
269 $state->{entries}{$state->{directory}.$data[1]} = {
270 revision => $data[2],
271 conflict => $data[3],
273 tag_or_date => $data[5],
278 # Response expected: yes. Add a file or directory. This uses any previous
279 # Argument, Directory, Entry, or Modified requests, if they have been sent.
280 # The last Directory sent specifies the working directory at the time of
281 # the operation. To add a directory, send the directory to be added using
282 # Directory and Argument requests.
285 my ( $cmd, $data ) = @_;
291 foreach my $filename ( @{$state->{args}} )
293 $filename = filecleanup($filename);
295 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
297 print "E cvs add: nothing known about `$filename'\n";
300 # TODO : check we're not squashing an already existing file
301 if ( defined ( $state->{entries}{$filename}{revision} ) )
303 print "E cvs add: `$filename' has already been entered\n";
308 my ( $filepart, $dirpart ) = filenamesplit($filename);
310 print "E cvs add: scheduling file `$filename' for addition\n";
312 print "Checked-in $dirpart\n";
314 print "/$filepart/0///\n";
319 if ( $addcount == 1 )
321 print "E cvs add: use `cvs commit' to add this file permanently\n";
323 elsif ( $addcount > 1 )
325 print "E cvs add: use `cvs commit' to add these files permanently\n";
332 # Response expected: yes. Remove a file. This uses any previous Argument,
333 # Directory, Entry, or Modified requests, if they have been sent. The last
334 # Directory sent specifies the working directory at the time of the
335 # operation. Note that this request does not actually do anything to the
336 # repository; the only effect of a successful remove request is to supply
337 # the client with a new entries line containing `-' to indicate a removed
338 # file. In fact, the client probably could perform this operation without
339 # contacting the server, although using remove may cause the server to
340 # perform a few more checks. The client sends a subsequent ci request to
341 # actually record the removal in the repository.
344 my ( $cmd, $data ) = @_;
348 # Grab a handle to the SQLite db and do any necessary updates
349 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
352 #$log->debug("add state : " . Dumper($state));
356 foreach my $filename ( @{$state->{args}} )
358 $filename = filecleanup($filename);
360 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
362 print "E cvs remove: file `$filename' still in working directory\n";
366 my $meta = $updater->getmeta($filename);
367 my $wrev = revparse($filename);
369 unless ( defined ( $wrev ) )
371 print "E cvs remove: nothing known about `$filename'\n";
375 if ( defined($wrev) and $wrev < 0 )
377 print "E cvs remove: file `$filename' already scheduled for removal\n";
381 unless ( $wrev == $meta->{revision} )
383 # TODO : not sure if the format of this message is quite correct.
384 print "E cvs remove: Up to date check failed for `$filename'\n";
389 my ( $filepart, $dirpart ) = filenamesplit($filename);
391 print "E cvs remove: scheduling `$filename' for removal\n";
393 print "Checked-in $dirpart\n";
395 print "/$filepart/-1.$wrev///\n";
402 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
404 elsif ( $rmcount > 1 )
406 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
412 # Modified filename \n
413 # Response expected: no. Additional data: mode, \n, file transmission. Send
414 # the server a copy of one locally modified file. filename is a file within
415 # the most recent directory sent with Directory; it must not contain `/'.
416 # If the user is operating on only some files in a directory, only those
417 # files need to be included. This can also be sent without Entry, if there
418 # is no entry for the file.
421 my ( $cmd, $data ) = @_;
428 # Grab config information
429 my $blocksize = 8192;
430 my $bytesleft = $size;
433 # Get a filehandle/name to write it to
434 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
436 # Loop over file data writing out to temporary file.
439 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
440 read STDIN, $tmp, $blocksize;
442 $bytesleft -= $blocksize;
447 # Ensure we have something sensible for the file mode
448 if ( $mode =~ /u=(\w+)/ )
455 # Save the file data in $state
456 $state->{entries}{$state->{directory}.$data}{modified_filename} = $filename;
457 $state->{entries}{$state->{directory}.$data}{modified_mode} = $mode;
458 $state->{entries}{$state->{directory}.$data}{modified_hash} = `git-hash-object $filename`;
459 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
461 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
464 # Unchanged filename \n
465 # Response expected: no. Tell the server that filename has not been
466 # modified in the checked out directory. The filename is a file within the
467 # most recent directory sent with Directory; it must not contain `/'.
470 my ( $cmd, $data ) = @_;
472 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
474 #$log->debug("req_Unchanged : $data");
477 # Questionable filename \n
478 # Response expected: no. Additional data: no.
479 # Tell the server to check whether filename should be ignored,
480 # and if not, next time the server sends responses, send (in
481 # a M response) `?' followed by the directory and filename.
482 # filename must not contain `/'; it needs to be a file in the
483 # directory named by the most recent Directory request.
486 my ( $cmd, $data ) = @_;
488 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
490 #$log->debug("req_Questionable : $data");
494 # Response expected: no. Save argument for use in a subsequent command.
495 # Arguments accumulate until an argument-using command is given, at which
496 # point they are forgotten.
498 # Response expected: no. Append \n followed by text to the current argument
502 my ( $cmd, $data ) = @_;
504 # TODO : Not quite sure how Argument and Argumentx differ, but I assume
505 # it's for multi-line arguments ... somehow ...
507 $log->debug("$cmd : $data");
509 push @{$state->{arguments}}, $data;
513 # Response expected: yes. Expand the modules which are specified in the
514 # arguments. Returns the data in Module-expansion responses. Note that the
515 # server can assume that this is checkout or export, not rtag or rdiff; the
516 # latter do not access the working directory and thus have no need to
517 # expand modules on the client side. Expand may not be the best word for
518 # what this request does. It does not necessarily tell you all the files
519 # contained in a module, for example. Basically it is a way of telling you
520 # which working directories the server needs to know about in order to
521 # handle a checkout of the specified modules. For example, suppose that the
522 # server has a module defined by
523 # aliasmodule -a 1dir
524 # That is, one can check out aliasmodule and it will take 1dir in the
525 # repository and check it out to 1dir in the working directory. Now suppose
526 # the client already has this module checked out and is planning on using
527 # the co request to update it. Without using expand-modules, the client
528 # would have two bad choices: it could either send information about all
529 # working directories under the current directory, which could be
530 # unnecessarily slow, or it could be ignorant of the fact that aliasmodule
531 # stands for 1dir, and neglect to send information for 1dir, which would
532 # lead to incorrect operation. With expand-modules, the client would first
533 # ask for the module to be expanded:
534 sub req_expandmodules
536 my ( $cmd, $data ) = @_;
540 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
542 unless ( ref $state->{arguments} eq "ARRAY" )
548 foreach my $module ( @{$state->{arguments}} )
550 $log->debug("SEND : Module-expansion $module");
551 print "Module-expansion $module\n";
559 # Response expected: yes. Get files from the repository. This uses any
560 # previous Argument, Directory, Entry, or Modified requests, if they have
561 # been sent. Arguments to this command are module names; the client cannot
562 # know what directories they correspond to except by (1) just sending the
563 # co request, and then seeing what directory names the server sends back in
564 # its responses, and (2) the expand-modules request.
567 my ( $cmd, $data ) = @_;
571 my $module = $state->{args}[0];
572 my $checkout_path = $module;
574 # use the user specified directory if we're given it
575 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
577 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
579 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
581 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
583 # Grab a handle to the SQLite db and do any necessary updates
584 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
587 $checkout_path =~ s|/$||; # get rid of trailing slashes
589 # Eclipse seems to need the Clear-sticky command
590 # to prepare the 'Entries' file for the new directory.
591 print "Clear-sticky $checkout_path/\n";
592 print $state->{CVSROOT} . "/$module/\n";
593 print "Clear-static-directory $checkout_path/\n";
594 print $state->{CVSROOT} . "/$module/\n";
595 print "Clear-sticky $checkout_path/\n"; # yes, twice
596 print $state->{CVSROOT} . "/$module/\n";
597 print "Template $checkout_path/\n";
598 print $state->{CVSROOT} . "/$module/\n";
601 # instruct the client that we're checking out to $checkout_path
602 print "E cvs checkout: Updating $checkout_path\n";
609 my ($dir, $repodir, $remotedir, $seendirs) = @_;
610 my $parent = dirname($dir);
613 $remotedir =~ s|/+$||;
615 $log->debug("announcedir $dir, $repodir, $remotedir" );
617 if ($parent eq '.' || $parent eq './') {
620 # recurse to announce unseen parents first
621 if (length($parent) && !exists($seendirs->{$parent})) {
622 prepdir($parent, $repodir, $remotedir, $seendirs);
624 # Announce that we are going to modify at the parent level
626 print "E cvs checkout: Updating $remotedir/$parent\n";
628 print "E cvs checkout: Updating $remotedir\n";
630 print "Clear-sticky $remotedir/$parent/\n";
631 print "$repodir/$parent/\n";
633 print "Clear-static-directory $remotedir/$dir/\n";
634 print "$repodir/$dir/\n";
635 print "Clear-sticky $remotedir/$parent/\n"; # yes, twice
636 print "$repodir/$parent/\n";
637 print "Template $remotedir/$dir/\n";
638 print "$repodir/$dir/\n";
641 $seendirs->{$dir} = 1;
644 foreach my $git ( @{$updater->gethead} )
646 # Don't want to check out deleted files
647 next if ( $git->{filehash} eq "deleted" );
649 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
651 if (length($git->{dir}) && $git->{dir} ne './'
652 && $git->{dir} ne $lastdir ) {
653 unless (exists($seendirs{$git->{dir}})) {
654 prepdir($git->{dir}, $state->{CVSROOT} . "/$module/",
655 $checkout_path, \%seendirs);
656 $lastdir = $git->{dir};
657 $seendirs{$git->{dir}} = 1;
659 print "E cvs checkout: Updating /$checkout_path/$git->{dir}\n";
662 # modification time of this file
663 print "Mod-time $git->{modified}\n";
665 # print some information to the client
666 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
668 print "M U $checkout_path/$git->{dir}$git->{name}\n";
670 print "M U $checkout_path/$git->{name}\n";
673 # instruct client we're sending a file to put in this path
674 print "Created $checkout_path/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "\n";
676 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
678 # this is an "entries" line
679 print "/$git->{name}/1.$git->{revision}///\n";
681 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
684 transmitfile($git->{filehash});
693 # Response expected: yes. Actually do a cvs update command. This uses any
694 # previous Argument, Directory, Entry, or Modified requests, if they have
695 # been sent. The last Directory sent specifies the working directory at the
696 # time of the operation. The -I option is not used--files which the client
697 # can decide whether to ignore are not mentioned and the client sends the
698 # Questionable request for others.
701 my ( $cmd, $data ) = @_;
703 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
708 # It may just be a client exploring the available heads/modukles
709 # in that case, list them as top level directories and leave it
710 # at that. Eclipse uses this technique to offer you a list of
711 # projects (heads in this case) to checkout.
713 if ($state->{module} eq '') {
714 print "E cvs update: Updating .\n";
715 opendir HEADS, $state->{CVSROOT} . '/refs/heads';
716 while (my $head = readdir(HEADS)) {
717 if (-f $state->{CVSROOT} . '/refs/heads/' . $head) {
718 print "E cvs update: New directory `$head'\n";
727 # Grab a handle to the SQLite db and do any necessary updates
728 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
732 # if no files were specified, we need to work out what files we should be providing status on ...
733 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
735 #$log->debug("update state : " . Dumper($state));
737 # foreach file specified on the commandline ...
738 foreach my $filename ( @{$state->{args}} )
740 $filename = filecleanup($filename);
742 # if we have a -C we should pretend we never saw modified stuff
743 if ( exists ( $state->{opt}{C} ) )
745 delete $state->{entries}{$filename}{modified_hash};
746 delete $state->{entries}{$filename}{modified_filename};
747 $state->{entries}{$filename}{unchanged} = 1;
751 if ( defined($state->{opt}{r}) and $state->{opt}{r} =~ /^1\.(\d+)/ )
753 $meta = $updater->getmeta($filename, $1);
755 $meta = $updater->getmeta($filename);
758 next unless ( $meta->{revision} );
762 my $wrev = revparse($filename);
764 # If the working copy is an old revision, lets get that version too for comparison.
765 if ( defined($wrev) and $wrev != $meta->{revision} )
767 $oldmeta = $updater->getmeta($filename, $wrev);
770 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
772 # Files are up to date if the working copy and repo copy have the same revision,
773 # and the working copy is unmodified _and_ the user hasn't specified -C
774 next if ( defined ( $wrev )
775 and defined($meta->{revision})
776 and $wrev == $meta->{revision}
777 and $state->{entries}{$filename}{unchanged}
778 and not exists ( $state->{opt}{C} ) );
780 # If the working copy and repo copy have the same revision,
781 # but the working copy is modified, tell the client it's modified
782 if ( defined ( $wrev )
783 and defined($meta->{revision})
784 and $wrev == $meta->{revision}
785 and not exists ( $state->{opt}{C} ) )
787 $log->info("Tell the client the file is modified");
789 print "MT fname $filename\n";
790 print "MT newline\n";
794 if ( $meta->{filehash} eq "deleted" )
796 my ( $filepart, $dirpart ) = filenamesplit($filename);
798 $log->info("Removing '$filename' from working copy (no longer in the repo)");
800 print "E cvs update: `$filename' is no longer in the repository\n";
801 print "Removed $dirpart\n";
804 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
805 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} )
807 $log->info("Updating '$filename'");
808 # normal update, just send the new revision (either U=Update, or A=Add, or R=Remove)
809 print "MT +updated\n";
811 print "MT fname $filename\n";
812 print "MT newline\n";
813 print "MT -updated\n";
815 my ( $filepart, $dirpart ) = filenamesplit($filename);
816 $dirpart =~ s/^$state->{directory}//;
818 if ( defined ( $wrev ) )
820 # instruct client we're sending a file to put in this path as a replacement
821 print "Update-existing $dirpart\n";
822 $log->debug("Updating existing file 'Update-existing $dirpart'");
824 # instruct client we're sending a file to put in this path as a new file
825 print "Created $dirpart\n";
826 $log->debug("Creating new file 'Created $dirpart'");
828 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
830 # this is an "entries" line
831 $log->debug("/$filepart/1.$meta->{revision}///");
832 print "/$filepart/1.$meta->{revision}///\n";
835 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
836 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
839 transmitfile($meta->{filehash});
841 $log->info("Updating '$filename'");
842 my ( $filepart, $dirpart ) = filenamesplit($meta->{name});
844 my $dir = tempdir( DIR => $TEMP_DIR, CLEANUP => 1 ) . "/";
847 my $file_local = $filepart . ".mine";
848 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
849 my $file_old = $filepart . "." . $oldmeta->{revision};
850 transmitfile($oldmeta->{filehash}, $file_old);
851 my $file_new = $filepart . "." . $meta->{revision};
852 transmitfile($meta->{filehash}, $file_new);
854 # we need to merge with the local changes ( M=successful merge, C=conflict merge )
855 $log->info("Merging $file_local, $file_old, $file_new");
857 $log->debug("Temporary directory for merge is $dir");
859 my $return = system("merge", $file_local, $file_old, $file_new);
864 $log->info("Merged successfully");
865 print "M M $filename\n";
866 $log->debug("Update-existing $dirpart");
867 print "Update-existing $dirpart\n";
868 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
869 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
870 $log->debug("/$filepart/1.$meta->{revision}///");
871 print "/$filepart/1.$meta->{revision}///\n";
873 elsif ( $return == 1 )
875 $log->info("Merged with conflicts");
876 print "M C $filename\n";
877 print "Update-existing $dirpart\n";
878 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
879 print "/$filepart/1.$meta->{revision}/+//\n";
883 $log->warn("Merge failed");
888 $log->debug("SEND : u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}");
889 print "u=$meta->{mode},g=$meta->{mode},o=$meta->{mode}\n";
891 # transmit file, format is single integer on a line by itself (file
892 # size) followed by the file contents
893 # TODO : we should copy files in blocks
894 my $data = `cat $file_local`;
895 $log->debug("File size : " . length($data));
896 print length($data) . "\n";
909 my ( $cmd, $data ) = @_;
913 #$log->debug("State : " . Dumper($state));
915 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
917 if ( -e $state->{CVSROOT} . "/index" )
919 print "error 1 Index already exists in git repo\n";
923 my $lockfile = "$state->{CVSROOT}/refs/heads/$state->{module}.lock";
924 unless ( sysopen(LOCKFILE,$lockfile,O_EXCL|O_CREAT|O_WRONLY) )
926 print "error 1 Lock file '$lockfile' already exists, please try again\n";
930 # Grab a handle to the SQLite db and do any necessary updates
931 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
934 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
935 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
936 $log->info("Lock successful, basing commit on '$tmpdir', index file is '$file_index'");
938 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
939 $ENV{GIT_INDEX_FILE} = $file_index;
943 # populate the temporary index based
944 system("git-read-tree", $state->{module});
947 die "Error running git-read-tree $state->{module} $file_index $!";
949 $log->info("Created index '$file_index' with for head $state->{module} - exit status $?");
952 my @committedfiles = ();
954 # foreach file specified on the commandline ...
955 foreach my $filename ( @{$state->{args}} )
957 $filename = filecleanup($filename);
959 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
961 my $meta = $updater->getmeta($filename);
963 my $wrev = revparse($filename);
965 my ( $filepart, $dirpart ) = filenamesplit($filename);
967 # do a checkout of the file if it part of this tree
969 system('git-checkout-index', '-f', '-u', $filename);
971 die "Error running git-checkout-index -f -u $filename : $!";
977 $rmflag = 1 if ( defined($wrev) and $wrev < 0 );
978 $addflag = 1 unless ( -e $filename );
980 # Do up to date checking
981 unless ( $addflag or $wrev == $meta->{revision} or ( $rmflag and -$wrev == $meta->{revision} ) )
983 # fail everything if an up to date check fails
984 print "error 1 Up to date check failed for $filename\n";
991 push @committedfiles, $filename;
992 $log->info("Committing $filename");
994 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
998 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
999 rename $state->{entries}{$filename}{modified_filename},$filename;
1001 # Calculate modes to remove
1003 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1005 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1006 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1011 $log->info("Removing file '$filename'");
1013 system("git-update-index", "--remove", $filename);
1017 $log->info("Adding file '$filename'");
1018 system("git-update-index", "--add", $filename);
1020 $log->info("Updating file '$filename'");
1021 system("git-update-index", $filename);
1025 unless ( scalar(@committedfiles) > 0 )
1027 print "E No files to commit\n";
1035 my $treehash = `git-write-tree`;
1036 my $parenthash = `cat $ENV{GIT_DIR}refs/heads/$state->{module}`;
1040 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1042 # write our commit message out if we have one ...
1043 my ( $msg_fh, $msg_filename ) = tempfile( DIR => $TEMP_DIR );
1044 print $msg_fh $state->{opt}{m};# if ( exists ( $state->{opt}{m} ) );
1045 print $msg_fh "\n\nvia git-CVS emulator\n";
1048 my $commithash = `git-commit-tree $treehash -p $parenthash < $msg_filename`;
1049 $log->info("Commit hash : $commithash");
1051 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1053 $log->warn("Commit failed (Invalid commit hash)");
1054 print "error 1 Commit failed (unknown reason)\n";
1061 open FILE, ">", "$ENV{GIT_DIR}refs/heads/$state->{module}";
1062 print FILE $commithash;
1067 # foreach file specified on the commandline ...
1068 foreach my $filename ( @committedfiles )
1070 $filename = filecleanup($filename);
1072 my $meta = $updater->getmeta($filename);
1074 my ( $filepart, $dirpart ) = filenamesplit($filename);
1076 $log->debug("Checked-in $dirpart : $filename");
1078 if ( $meta->{filehash} eq "deleted" )
1080 print "Remove-entry $dirpart\n";
1081 print "$filename\n";
1083 print "Checked-in $dirpart\n";
1084 print "$filename\n";
1085 print "/$filepart/1.$meta->{revision}///\n";
1098 my ( $cmd, $data ) = @_;
1102 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1103 #$log->debug("status state : " . Dumper($state));
1105 # Grab a handle to the SQLite db and do any necessary updates
1106 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1109 # if no files were specified, we need to work out what files we should be providing status on ...
1110 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1112 # foreach file specified on the commandline ...
1113 foreach my $filename ( @{$state->{args}} )
1115 $filename = filecleanup($filename);
1117 my $meta = $updater->getmeta($filename);
1118 my $oldmeta = $meta;
1120 my $wrev = revparse($filename);
1122 # If the working copy is an old revision, lets get that version too for comparison.
1123 if ( defined($wrev) and $wrev != $meta->{revision} )
1125 $oldmeta = $updater->getmeta($filename, $wrev);
1128 # TODO : All possible statuses aren't yet implemented
1130 # Files are up to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1131 $status = "Up-to-date" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision}
1133 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1134 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta->{filehash} ) )
1137 # Need checkout if the working copy has an older revision than the repo copy, and the working copy is unmodified
1138 $status ||= "Needs Checkout" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev
1140 ( $state->{entries}{$filename}{unchanged}
1141 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash} ) )
1144 # Need checkout if it exists in the repo but doesn't have a working copy
1145 $status ||= "Needs Checkout" if ( not defined ( $wrev ) and defined ( $meta->{revision} ) );
1147 # Locally modified if working copy and repo copy have the same revision but there are local changes
1148 $status ||= "Locally Modified" if ( defined ( $wrev ) and defined($meta->{revision}) and $wrev == $meta->{revision} and $state->{entries}{$filename}{modified_filename} );
1150 # Needs Merge if working copy revision is less than repo copy and there are local changes
1151 $status ||= "Needs Merge" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and $meta->{revision} > $wrev and $state->{entries}{$filename}{modified_filename} );
1153 $status ||= "Locally Added" if ( defined ( $state->{entries}{$filename}{revision} ) and not defined ( $meta->{revision} ) );
1154 $status ||= "Locally Removed" if ( defined ( $wrev ) and defined ( $meta->{revision} ) and -$wrev == $meta->{revision} );
1155 $status ||= "Unresolved Conflict" if ( defined ( $state->{entries}{$filename}{conflict} ) and $state->{entries}{$filename}{conflict} =~ /^\+=/ );
1156 $status ||= "File had conflicts on merge" if ( 0 );
1158 $status ||= "Unknown";
1160 print "M ===================================================================\n";
1161 print "M File: $filename\tStatus: $status\n";
1162 if ( defined($state->{entries}{$filename}{revision}) )
1164 print "M Working revision:\t" . $state->{entries}{$filename}{revision} . "\n";
1166 print "M Working revision:\tNo entry for $filename\n";
1168 if ( defined($meta->{revision}) )
1170 print "M Repository revision:\t1." . $meta->{revision} . "\t$state->{repository}/$filename,v\n";
1171 print "M Sticky Tag:\t\t(none)\n";
1172 print "M Sticky Date:\t\t(none)\n";
1173 print "M Sticky Options:\t\t(none)\n";
1175 print "M Repository revision:\tNo revision control file\n";
1185 my ( $cmd, $data ) = @_;
1189 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1190 #$log->debug("status state : " . Dumper($state));
1192 my ($revision1, $revision2);
1193 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1195 $revision1 = $state->{opt}{r}[0];
1196 $revision2 = $state->{opt}{r}[1];
1198 $revision1 = $state->{opt}{r};
1201 $revision1 =~ s/^1\.// if ( defined ( $revision1 ) );
1202 $revision2 =~ s/^1\.// if ( defined ( $revision2 ) );
1204 $log->debug("Diffing revisions " . ( defined($revision1) ? $revision1 : "[NULL]" ) . " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
1206 # Grab a handle to the SQLite db and do any necessary updates
1207 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1210 # if no files were specified, we need to work out what files we should be providing status on ...
1211 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1213 # foreach file specified on the commandline ...
1214 foreach my $filename ( @{$state->{args}} )
1216 $filename = filecleanup($filename);
1218 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
1220 my $wrev = revparse($filename);
1222 # We need _something_ to diff against
1223 next unless ( defined ( $wrev ) );
1225 # if we have a -r switch, use it
1226 if ( defined ( $revision1 ) )
1228 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1229 $meta1 = $updater->getmeta($filename, $revision1);
1230 unless ( defined ( $meta1 ) and $meta1->{filehash} ne "deleted" )
1232 print "E File $filename at revision 1.$revision1 doesn't exist\n";
1235 transmitfile($meta1->{filehash}, $file1);
1237 # otherwise we just use the working copy revision
1240 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1241 $meta1 = $updater->getmeta($filename, $wrev);
1242 transmitfile($meta1->{filehash}, $file1);
1245 # if we have a second -r switch, use it too
1246 if ( defined ( $revision2 ) )
1248 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1249 $meta2 = $updater->getmeta($filename, $revision2);
1251 unless ( defined ( $meta2 ) and $meta2->{filehash} ne "deleted" )
1253 print "E File $filename at revision 1.$revision2 doesn't exist\n";
1257 transmitfile($meta2->{filehash}, $file2);
1259 # otherwise we just use the working copy
1262 $file2 = $state->{entries}{$filename}{modified_filename};
1265 # if we have been given -r, and we don't have a $file2 yet, lets get one
1266 if ( defined ( $revision1 ) and not defined ( $file2 ) )
1268 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
1269 $meta2 = $updater->getmeta($filename, $wrev);
1270 transmitfile($meta2->{filehash}, $file2);
1273 # We need to have retrieved something useful
1274 next unless ( defined ( $meta1 ) );
1276 # Files to date if the working copy and repo copy have the same revision, and the working copy is unmodified
1277 next if ( not defined ( $meta2 ) and $wrev == $meta1->{revision}
1279 ( ( $state->{entries}{$filename}{unchanged} and ( not defined ( $state->{entries}{$filename}{conflict} ) or $state->{entries}{$filename}{conflict} !~ /^\+=/ ) )
1280 or ( defined($state->{entries}{$filename}{modified_hash}) and $state->{entries}{$filename}{modified_hash} eq $meta1->{filehash} ) )
1283 # Apparently we only show diffs for locally modified files
1284 next unless ( defined($meta2) or defined ( $state->{entries}{$filename}{modified_filename} ) );
1286 print "M Index: $filename\n";
1287 print "M ===================================================================\n";
1288 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1289 print "M retrieving revision 1.$meta1->{revision}\n" if ( defined ( $meta1 ) );
1290 print "M retrieving revision 1.$meta2->{revision}\n" if ( defined ( $meta2 ) );
1292 foreach my $opt ( keys %{$state->{opt}} )
1294 if ( ref $state->{opt}{$opt} eq "ARRAY" )
1296 foreach my $value ( @{$state->{opt}{$opt}} )
1298 print "-$opt $value ";
1302 print "$state->{opt}{$opt} " if ( defined ( $state->{opt}{$opt} ) );
1305 print "$filename\n";
1307 $log->info("Diffing $filename -r $meta1->{revision} -r " . ( $meta2->{revision} or "workingcopy" ));
1309 ( $fh, $filediff ) = tempfile ( DIR => $TEMP_DIR );
1311 if ( exists $state->{opt}{u} )
1313 system("diff -u -L '$filename revision 1.$meta1->{revision}' -L '$filename " . ( defined($meta2->{revision}) ? "revision 1.$meta2->{revision}" : "working copy" ) . "' $file1 $file2 > $filediff");
1315 system("diff $file1 $file2 > $filediff");
1330 my ( $cmd, $data ) = @_;
1334 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
1335 #$log->debug("log state : " . Dumper($state));
1337 my ( $minrev, $maxrev );
1338 if ( defined ( $state->{opt}{r} ) and $state->{opt}{r} =~ /([\d.]+)?(::?)([\d.]+)?/ )
1343 $minrev =~ s/^1\.// if ( defined ( $minrev ) );
1344 $maxrev =~ s/^1\.// if ( defined ( $maxrev ) );
1345 $minrev++ if ( defined($minrev) and $control eq "::" );
1348 # Grab a handle to the SQLite db and do any necessary updates
1349 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1352 # if no files were specified, we need to work out what files we should be providing status on ...
1353 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1355 # foreach file specified on the commandline ...
1356 foreach my $filename ( @{$state->{args}} )
1358 $filename = filecleanup($filename);
1360 my $headmeta = $updater->getmeta($filename);
1362 my $revisions = $updater->getlog($filename);
1363 my $totalrevisions = scalar(@$revisions);
1365 if ( defined ( $minrev ) )
1367 $log->debug("Removing revisions less than $minrev");
1368 while ( scalar(@$revisions) > 0 and $revisions->[-1]{revision} < $minrev )
1373 if ( defined ( $maxrev ) )
1375 $log->debug("Removing revisions greater than $maxrev");
1376 while ( scalar(@$revisions) > 0 and $revisions->[0]{revision} > $maxrev )
1382 next unless ( scalar(@$revisions) );
1385 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
1386 print "M Working file: $filename\n";
1387 print "M head: 1.$headmeta->{revision}\n";
1388 print "M branch:\n";
1389 print "M locks: strict\n";
1390 print "M access list:\n";
1391 print "M symbolic names:\n";
1392 print "M keyword substitution: kv\n";
1393 print "M total revisions: $totalrevisions;\tselected revisions: " . scalar(@$revisions) . "\n";
1394 print "M description:\n";
1396 foreach my $revision ( @$revisions )
1398 print "M ----------------------------\n";
1399 print "M revision 1.$revision->{revision}\n";
1400 # reformat the date for log output
1401 $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}) );
1402 $revision->{author} =~ s/\s+.*//;
1403 $revision->{author} =~ s/^(.{8}).*/$1/;
1404 print "M date: $revision->{modified}; author: $revision->{author}; state: " . ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) . "; lines: +2 -3\n";
1405 my $commitmessage = $updater->commitmessage($revision->{commithash});
1406 $commitmessage =~ s/^/M /mg;
1407 print $commitmessage . "\n";
1409 print "M =============================================================================\n";
1417 my ( $cmd, $data ) = @_;
1419 argsplit("annotate");
1421 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
1422 #$log->debug("status state : " . Dumper($state));
1424 # Grab a handle to the SQLite db and do any necessary updates
1425 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1428 # if no files were specified, we need to work out what files we should be providing annotate on ...
1429 argsfromdir($updater) if ( scalar ( @{$state->{args}} ) == 0 );
1431 # we'll need a temporary checkout dir
1432 my $tmpdir = tempdir ( DIR => $TEMP_DIR );
1433 my ( undef, $file_index ) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
1434 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$tmpdir', index file is '$file_index'");
1436 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
1437 $ENV{GIT_INDEX_FILE} = $file_index;
1441 # foreach file specified on the commandline ...
1442 foreach my $filename ( @{$state->{args}} )
1444 $filename = filecleanup($filename);
1446 my $meta = $updater->getmeta($filename);
1448 next unless ( $meta->{revision} );
1450 # get all the commits that this file was in
1451 # in dense format -- aka skip dead revisions
1452 my $revisions = $updater->gethistorydense($filename);
1453 my $lastseenin = $revisions->[0][2];
1455 # populate the temporary index based on the latest commit were we saw
1456 # the file -- but do it cheaply without checking out any files
1457 # TODO: if we got a revision from the client, use that instead
1458 # to look up the commithash in sqlite (still good to default to
1459 # the current head as we do now)
1460 system("git-read-tree", $lastseenin);
1463 die "Error running git-read-tree $lastseenin $file_index $!";
1465 $log->info("Created index '$file_index' with commit $lastseenin - exit status $?");
1467 # do a checkout of the file
1468 system('git-checkout-index', '-f', '-u', $filename);
1470 die "Error running git-checkout-index -f -u $filename : $!";
1473 $log->info("Annotate $filename");
1475 # Prepare a file with the commits from the linearized
1476 # history that annotate should know about. This prevents
1477 # git-jsannotate telling us about commits we are hiding
1480 open(ANNOTATEHINTS, ">$tmpdir/.annotate_hints") or die "Error opening > $tmpdir/.annotate_hints $!";
1481 for (my $i=0; $i < @$revisions; $i++)
1483 print ANNOTATEHINTS $revisions->[$i][2];
1484 if ($i+1 < @$revisions) { # have we got a parent?
1485 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
1487 print ANNOTATEHINTS "\n";
1490 print ANNOTATEHINTS "\n";
1491 close ANNOTATEHINTS;
1493 my $annotatecmd = 'git-annotate';
1494 open(ANNOTATE, "-|", $annotatecmd, '-l', '-S', "$tmpdir/.annotate_hints", $filename)
1495 or die "Error invoking $annotatecmd -l -S $tmpdir/.annotate_hints $filename : $!";
1497 print "E Annotations for $filename\n";
1498 print "E ***************\n";
1499 while ( <ANNOTATE> )
1501 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
1503 my $commithash = $1;
1505 unless ( defined ( $metadata->{$commithash} ) )
1507 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
1508 $metadata->{$commithash}{author} =~ s/\s+.*//;
1509 $metadata->{$commithash}{author} =~ s/^(.{8}).*/$1/;
1510 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
1512 printf("M 1.%-5d (%-8s %10s): %s\n",
1513 $metadata->{$commithash}{revision},
1514 $metadata->{$commithash}{author},
1515 $metadata->{$commithash}{modified},
1519 $log->warn("Error in annotate output! LINE: $_");
1520 print "E Annotate error \n";
1527 # done; get out of the tempdir
1534 # This method takes the state->{arguments} array and produces two new arrays.
1535 # The first is $state->{args} which is everything before the '--' argument, and
1536 # the second is $state->{files} which is everything after it.
1539 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
1543 $state->{args} = [];
1544 $state->{files} = [];
1547 if ( defined($type) )
1550 $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" );
1551 $opt = { v => 0, l => 0, R => 0 } if ( $type eq "status" );
1552 $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" );
1553 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2 } if ( $type eq "diff" );
1554 $opt = { c => 0, R => 0, l => 0, f => 0, F => 1, m => 1, r => 1 } if ( $type eq "ci" );
1555 $opt = { k => 1, m => 1 } if ( $type eq "add" );
1556 $opt = { f => 0, l => 0, R => 0 } if ( $type eq "remove" );
1557 $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" );
1560 while ( scalar ( @{$state->{arguments}} ) > 0 )
1562 my $arg = shift @{$state->{arguments}};
1564 next if ( $arg eq "--" );
1565 next unless ( $arg =~ /\S/ );
1567 # if the argument looks like a switch
1568 if ( $arg =~ /^-(\w)(.*)/ )
1570 # if it's a switch that takes an argument
1573 # If this switch has already been provided
1574 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
1576 $state->{opt}{$1} = [ $state->{opt}{$1} ];
1577 if ( length($2) > 0 )
1579 push @{$state->{opt}{$1}},$2;
1581 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
1584 # if there's extra data in the arg, use that as the argument for the switch
1585 if ( length($2) > 0 )
1587 $state->{opt}{$1} = $2;
1589 $state->{opt}{$1} = shift @{$state->{arguments}};
1593 $state->{opt}{$1} = undef;
1598 push @{$state->{args}}, $arg;
1606 foreach my $value ( @{$state->{arguments}} )
1608 if ( $value eq "--" )
1613 push @{$state->{args}}, $value if ( $mode == 0 );
1614 push @{$state->{files}}, $value if ( $mode == 1 );
1619 # This method uses $state->{directory} to populate $state->{args} with a list of filenames
1622 my $updater = shift;
1624 $state->{args} = [];
1626 foreach my $file ( @{$updater->gethead} )
1628 next if ( $file->{filehash} eq "deleted" and not defined ( $state->{entries}{$file->{name}} ) );
1629 next unless ( $file->{name} =~ s/^$state->{directory}// );
1630 push @{$state->{args}}, $file->{name};
1634 # This method cleans up the $state variable after a command that uses arguments has run
1637 $state->{files} = [];
1638 $state->{args} = [];
1639 $state->{arguments} = [];
1640 $state->{entries} = {};
1645 my $filename = shift;
1647 return undef unless ( defined ( $state->{entries}{$filename}{revision} ) );
1649 return $1 if ( $state->{entries}{$filename}{revision} =~ /^1\.(\d+)/ );
1650 return -$1 if ( $state->{entries}{$filename}{revision} =~ /^-1\.(\d+)/ );
1655 # This method takes a file hash and does a CVS "file transfer" which transmits the
1656 # size of the file, and then the file contents.
1657 # If a second argument $targetfile is given, the file is instead written out to
1658 # a file by the name of $targetfile
1661 my $filehash = shift;
1662 my $targetfile = shift;
1664 if ( defined ( $filehash ) and $filehash eq "deleted" )
1666 $log->warn("filehash is 'deleted'");
1670 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
1672 my $type = `git-cat-file -t $filehash`;
1675 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
1677 my $size = `git-cat-file -s $filehash`;
1680 $log->debug("transmitfile($filehash) size=$size, type=$type");
1682 if ( open my $fh, '-|', "git-cat-file", "blob", $filehash )
1684 if ( defined ( $targetfile ) )
1686 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
1687 print NEWFILE $_ while ( <$fh> );
1691 print while ( <$fh> );
1693 close $fh or die ("Couldn't close filehandle for transmitfile()");
1695 die("Couldn't execute git-cat-file");
1699 # This method takes a file name, and returns ( $dirpart, $filepart ) which
1700 # refers to the directory porition and the file portion of the filename
1704 my $filename = shift;
1706 my ( $filepart, $dirpart ) = ( $filename, "." );
1707 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
1710 return ( $filepart, $dirpart );
1715 my $filename = shift;
1717 return undef unless(defined($filename));
1718 if ( $filename =~ /^\// )
1720 print "E absolute filenames '$filename' not supported by server\n";
1724 $filename =~ s/^\.\///g;
1725 $filename = $state->{directory} . $filename;
1730 package GITCVS::log;
1733 #### Copyright The Open University UK - 2006.
1735 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1736 #### Martin Langhoff <martin@catalyst.net.nz>
1749 This module provides very crude logging with a similar interface to
1758 Creates a new log object, optionally you can specify a filename here to
1759 indicate the file to log to. If no log file is specified, you can specifiy one
1760 later with method setfile, or indicate you no longer want logging with method
1763 Until one of these methods is called, all log calls will buffer messages ready
1770 my $filename = shift;
1774 bless $self, $class;
1776 if ( defined ( $filename ) )
1778 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1786 This methods takes a filename, and attempts to open that file as the log file.
1787 If successful, all buffered data is written out to the file, and any further
1788 logging is written directly to the file.
1794 my $filename = shift;
1796 if ( defined ( $filename ) )
1798 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
1801 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1803 while ( my $line = shift @{$self->{buffer}} )
1805 print {$self->{fh}} $line;
1811 This method indicates no logging is going to be used. It flushes any entries in
1812 the internal buffer, and sets a flag to ensure no further data is put there.
1821 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
1823 $self->{buffer} = [];
1828 Internal method. Returns true if the log file is open, false otherwise.
1835 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
1839 =head2 debug info warn fatal
1841 These four methods are wrappers to _log. They provide the actual interface for
1845 sub debug { my $self = shift; $self->_log("debug", @_); }
1846 sub info { my $self = shift; $self->_log("info" , @_); }
1847 sub warn { my $self = shift; $self->_log("warn" , @_); }
1848 sub fatal { my $self = shift; $self->_log("fatal", @_); }
1852 This is an internal method called by the logging functions. It generates a
1853 timestamp and pushes the logged line either to file, or internal buffer.
1861 return if ( $self->{nolog} );
1863 my @time = localtime;
1864 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
1874 if ( $self->_logopen )
1876 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
1878 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
1884 This method simply closes the file handle if one is open
1891 if ( $self->_logopen )
1897 package GITCVS::updater;
1900 #### Copyright The Open University UK - 2006.
1902 #### Authors: Martyn Smith <martyn@catalyst.net.nz>
1903 #### Martin Langhoff <martin@catalyst.net.nz>
1925 die "Need to specify a git repository" unless ( defined($config) and -d $config );
1926 die "Need to specify a module" unless ( defined($module) );
1928 $class = ref($class) || $class;
1932 bless $self, $class;
1934 $self->{dbdir} = $config . "/";
1935 die "Database dir '$self->{dbdir}' isn't a directory" unless ( defined($self->{dbdir}) and -d $self->{dbdir} );
1937 $self->{module} = $module;
1938 $self->{file} = $self->{dbdir} . "/gitcvs.$module.sqlite";
1940 $self->{git_path} = $config . "/";
1942 $self->{log} = $log;
1944 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
1946 $self->{dbh} = DBI->connect("dbi:SQLite:dbname=" . $self->{file},"","");
1948 $self->{tables} = {};
1949 foreach my $table ( $self->{dbh}->tables )
1953 $self->{tables}{$table} = 1;
1956 # Construct the revision table if required
1957 unless ( $self->{tables}{revision} )
1960 CREATE TABLE revision (
1962 revision INTEGER NOT NULL,
1963 filehash TEXT NOT NULL,
1964 commithash TEXT NOT NULL,
1965 author TEXT NOT NULL,
1966 modified TEXT NOT NULL,
1972 # Construct the revision table if required
1973 unless ( $self->{tables}{head} )
1978 revision INTEGER NOT NULL,
1979 filehash TEXT NOT NULL,
1980 commithash TEXT NOT NULL,
1981 author TEXT NOT NULL,
1982 modified TEXT NOT NULL,
1988 # Construct the properties table if required
1989 unless ( $self->{tables}{properties} )
1992 CREATE TABLE properties (
1993 key TEXT NOT NULL PRIMARY KEY,
1999 # Construct the commitmsgs table if required
2000 unless ( $self->{tables}{commitmsgs} )
2003 CREATE TABLE commitmsgs (
2004 key TEXT NOT NULL PRIMARY KEY,
2020 # first lets get the commit list
2021 $ENV{GIT_DIR} = $self->{git_path};
2023 # prepare database queries
2024 my $db_insert_rev = $self->{dbh}->prepare_cached("INSERT INTO revision (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2025 my $db_insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO commitmsgs (key, value) VALUES (?,?)",{},1);
2026 my $db_delete_head = $self->{dbh}->prepare_cached("DELETE FROM head",{},1);
2027 my $db_insert_head = $self->{dbh}->prepare_cached("INSERT INTO head (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
2029 my $commitinfo = `git-cat-file commit $self->{module} 2>&1`;
2030 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
2032 die("Invalid module '$self->{module}'");
2037 my $lastcommit = $self->_get_prop("last_commit");
2039 # Start exclusive lock here...
2040 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
2042 # TODO: log processing is memory bound
2043 # if we can parse into a 2nd file that is in reverse order
2044 # we can probably do something really efficient
2045 my @git_log_params = ('--parents', '--topo-order');
2047 if (defined $lastcommit) {
2048 push @git_log_params, "$lastcommit..$self->{module}";
2050 push @git_log_params, $self->{module};
2052 open(GITLOG, '-|', 'git-log', @git_log_params) or die "Cannot call git-log: $!";
2061 if (m/^commit\s+(.*)$/) {
2062 # on ^commit lines put the just seen commit in the stack
2063 # and prime things for the next one
2066 unshift @commits, \%copy;
2069 my @parents = split(m/\s+/, $1);
2070 $commit{hash} = shift @parents;
2071 $commit{parents} = \@parents;
2072 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
2073 # on rfc822-like lines seen before we see any message,
2074 # lowercase the entry and put it in the hash as key-value
2075 $commit{lc($1)} = $2;
2077 # message lines - skip initial empty line
2078 # and trim whitespace
2079 if (!exists($commit{message}) && m/^\s*$/) {
2080 # define it to mark the end of headers
2081 $commit{message} = '';
2084 s/^\s+//; s/\s+$//; # trim ws
2085 $commit{message} .= $_ . "\n";
2090 unshift @commits, \%commit if ( keys %commit );
2092 # Now all the commits are in the @commits bucket
2093 # ordered by time DESC. for each commit that needs processing,
2094 # determine whether it's following the last head we've seen or if
2095 # it's on its own branch, grab a file list, and add whatever's changed
2096 # NOTE: $lastcommit refers to the last commit from previous run
2097 # $lastpicked is the last commit we picked in this run
2100 if (defined $lastcommit) {
2101 $lastpicked = $lastcommit;
2104 my $committotal = scalar(@commits);
2105 my $commitcount = 0;
2107 # Load the head table into $head (for cached lookups during the update process)
2108 foreach my $file ( @{$self->gethead()} )
2110 $head->{$file->{name}} = $file;
2113 foreach my $commit ( @commits )
2115 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
2116 if (defined $lastpicked)
2118 if (!in_array($lastpicked, @{$commit->{parents}}))
2120 # skip, we'll see this delta
2121 # as part of a merge later
2122 # warn "skipping off-track $commit->{hash}\n";
2124 } elsif (@{$commit->{parents}} > 1) {
2125 # it is a merge commit, for each parent that is
2126 # not $lastpicked, see if we can get a log
2127 # from the merge-base to that parent to put it
2128 # in the message as a merge summary.
2129 my @parents = @{$commit->{parents}};
2130 foreach my $parent (@parents) {
2131 # git-merge-base can potentially (but rarely) throw
2132 # several candidate merge bases. let's assume
2133 # that the first one is the best one.
2134 if ($parent eq $lastpicked) {
2137 open my $p, 'git-merge-base '. $lastpicked . ' '
2139 my @output = (<$p>);
2141 my $base = join('', @output);
2145 # print "want to log between $base $parent \n";
2146 open(GITLOG, '-|', 'git-log', "$base..$parent")
2147 or die "Cannot call git-log: $!";
2151 if (!defined $mergedhash) {
2152 if (m/^commit\s+(.+)$/) {
2158 # grab the first line that looks non-rfc822
2159 # aka has content after leading space
2160 if (m/^\s+(\S.*)$/) {
2162 $title = substr($title,0,100); # truncate
2163 unshift @merged, "$mergedhash $title";
2170 $commit->{mergemsg} = $commit->{message};
2171 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
2172 foreach my $summary (@merged) {
2173 $commit->{mergemsg} .= "\t$summary\n";
2175 $commit->{mergemsg} .= "\n\n";
2176 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
2183 # convert the date to CVS-happy format
2184 $commit->{date} = "$2 $1 $4 $3 $5" if ( $commit->{date} =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ );
2186 if ( defined ( $lastpicked ) )
2188 my $filepipe = open(FILELIST, '-|', 'git-diff-tree', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
2189 while ( <FILELIST> )
2191 unless ( /^:\d{6}\s+\d{3}(\d)\d{2}\s+[a-zA-Z0-9]{40}\s+([a-zA-Z0-9]{40})\s+(\w)\s+(.*)$/o )
2193 die("Couldn't process git-diff-tree line : $_");
2196 # $log->debug("File mode=$1, hash=$2, change=$3, name=$4");
2199 $git_perms .= "r" if ( $1 & 4 );
2200 $git_perms .= "w" if ( $1 & 2 );
2201 $git_perms .= "x" if ( $1 & 1 );
2202 $git_perms = "rw" if ( $git_perms eq "" );
2206 #$log->debug("DELETE $4");
2209 revision => $head->{$4}{revision} + 1,
2210 filehash => "deleted",
2211 commithash => $commit->{hash},
2212 modified => $commit->{date},
2213 author => $commit->{author},
2216 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2220 #$log->debug("MODIFIED $4");
2223 revision => $head->{$4}{revision} + 1,
2225 commithash => $commit->{hash},
2226 modified => $commit->{date},
2227 author => $commit->{author},
2230 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2234 #$log->debug("ADDED $4");
2239 commithash => $commit->{hash},
2240 modified => $commit->{date},
2241 author => $commit->{author},
2244 $db_insert_rev->execute($4, $head->{$4}{revision}, $2, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2248 $log->warn("UNKNOWN FILE CHANGE mode=$1, hash=$2, change=$3, name=$4");
2254 # this is used to detect files removed from the repo
2255 my $seen_files = {};
2257 my $filepipe = open(FILELIST, '-|', 'git-ls-tree', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
2258 while ( <FILELIST> )
2260 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\s+(.*)$/o )
2262 die("Couldn't process git-ls-tree line : $_");
2265 my ( $git_perms, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
2267 $seen_files->{$git_filename} = 1;
2269 my ( $oldhash, $oldrevision, $oldmode ) = (
2270 $head->{$git_filename}{filehash},
2271 $head->{$git_filename}{revision},
2272 $head->{$git_filename}{mode}
2275 if ( $git_perms =~ /^\d\d\d(\d)\d\d/o )
2278 $git_perms .= "r" if ( $1 & 4 );
2279 $git_perms .= "w" if ( $1 & 2 );
2280 $git_perms .= "x" if ( $1 & 1 );
2285 # unless the file exists with the same hash, we need to update it ...
2286 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $git_perms )
2288 my $newrevision = ( $oldrevision or 0 ) + 1;
2290 $head->{$git_filename} = {
2291 name => $git_filename,
2292 revision => $newrevision,
2293 filehash => $git_hash,
2294 commithash => $commit->{hash},
2295 modified => $commit->{date},
2296 author => $commit->{author},
2301 $db_insert_rev->execute($git_filename, $newrevision, $git_hash, $commit->{hash}, $commit->{date}, $commit->{author}, $git_perms);
2306 # Detect deleted files
2307 foreach my $file ( keys %$head )
2309 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
2311 $head->{$file}{revision}++;
2312 $head->{$file}{filehash} = "deleted";
2313 $head->{$file}{commithash} = $commit->{hash};
2314 $head->{$file}{modified} = $commit->{date};
2315 $head->{$file}{author} = $commit->{author};
2317 $db_insert_rev->execute($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $commit->{date}, $commit->{author}, $head->{$file}{mode});
2320 # END : "Detect deleted files"
2324 if (exists $commit->{mergemsg})
2326 $db_insert_mergelog->execute($commit->{hash}, $commit->{mergemsg});
2329 $lastpicked = $commit->{hash};
2331 $self->_set_prop("last_commit", $commit->{hash});
2334 $db_delete_head->execute();
2335 foreach my $file ( keys %$head )
2337 $db_insert_head->execute(
2339 $head->{$file}{revision},
2340 $head->{$file}{filehash},
2341 $head->{$file}{commithash},
2342 $head->{$file}{modified},
2343 $head->{$file}{author},
2344 $head->{$file}{mode},
2347 # invalidate the gethead cache
2348 $self->{gethead_cache} = undef;
2351 # Ending exclusive lock here
2352 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
2358 my $filename = shift;
2360 my $db_query = $self->{dbh}->prepare_cached("SELECT filehash, revision, mode FROM head WHERE name=?",{},1);
2361 $db_query->execute($filename);
2362 my ( $hash, $revision, $mode ) = $db_query->fetchrow_array;
2364 return ( $hash, $revision, $mode );
2372 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM properties WHERE key=?",{},1);
2373 $db_query->execute($key);
2374 my ( $value ) = $db_query->fetchrow_array;
2385 my $db_query = $self->{dbh}->prepare_cached("UPDATE properties SET value=? WHERE key=?",{},1);
2386 $db_query->execute($value, $key);
2388 unless ( $db_query->rows )
2390 $db_query = $self->{dbh}->prepare_cached("INSERT INTO properties (key, value) VALUES (?,?)",{},1);
2391 $db_query->execute($key, $value);
2405 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
2407 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM head ORDER BY name ASC",{},1);
2408 $db_query->execute();
2411 while ( my $file = $db_query->fetchrow_hashref )
2416 $self->{gethead_cache} = $tree;
2428 my $filename = shift;
2430 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2431 $db_query->execute($filename);
2434 while ( my $file = $db_query->fetchrow_hashref )
2444 This function takes a filename (with path) argument and returns a hashref of
2445 metadata for that file.
2452 my $filename = shift;
2453 my $revision = shift;
2456 if ( defined($revision) and $revision =~ /^\d+$/ )
2458 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND revision=?",{},1);
2459 $db_query->execute($filename, $revision);
2461 elsif ( defined($revision) and $revision =~ /^[a-zA-Z0-9]{40}$/ )
2463 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM revision WHERE name=? AND commithash=?",{},1);
2464 $db_query->execute($filename, $revision);
2466 $db_query = $self->{dbh}->prepare_cached("SELECT * FROM head WHERE name=?",{},1);
2467 $db_query->execute($filename);
2470 return $db_query->fetchrow_hashref;
2473 =head2 commitmessage
2475 this function takes a commithash and returns the commit message for that commit
2481 my $commithash = shift;
2483 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
2486 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM commitmsgs WHERE key=?",{},1);
2487 $db_query->execute($commithash);
2489 my ( $message ) = $db_query->fetchrow_array;
2491 if ( defined ( $message ) )
2493 $message .= " " if ( $message =~ /\n$/ );
2497 my @lines = safe_pipe_capture("git-cat-file", "commit", $commithash);
2498 shift @lines while ( $lines[0] =~ /\S/ );
2499 $message = join("",@lines);
2500 $message .= " " if ( $message =~ /\n$/ );
2506 This function takes a filename (with path) argument and returns an arrayofarrays
2507 containing revision,filehash,commithash ordered by revision descending
2513 my $filename = shift;
2516 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? ORDER BY revision DESC",{},1);
2517 $db_query->execute($filename);
2519 return $db_query->fetchall_arrayref;
2522 =head2 gethistorydense
2524 This function takes a filename (with path) argument and returns an arrayofarrays
2525 containing revision,filehash,commithash ordered by revision descending.
2527 This version of gethistory skips deleted entries -- so it is useful for annotate.
2528 The 'dense' part is a reference to a '--dense' option available for git-rev-list
2529 and other git tools that depend on it.
2535 my $filename = shift;
2538 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM revision WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
2539 $db_query->execute($filename);
2541 return $db_query->fetchall_arrayref;
2546 from Array::PAT - mimics the in_array() function
2547 found in PHP. Yuck but works for small arrays.
2552 my ($check, @array) = @_;
2554 foreach my $test (@array){
2555 if($check eq $test){
2562 =head2 safe_pipe_capture
2564 an alterative to `command` that allows input to be passed as an array
2565 to work around shell problems with weird characters in arguments
2568 sub safe_pipe_capture {
2572 if (my $pid = open my $child, '-|') {
2573 @output = (<$child>);
2574 close $child or die join(' ',@_).": $! $?";
2576 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
2578 return wantarray ? @output : join('',@output);