]> git.ipfire.org Git - thirdparty/git.git/blame - git-cvsserver.perl
clean: optimize and document cases where we recurse into subdirectories
[thirdparty/git.git] / git-cvsserver.perl
CommitLineData
3fda8c4c
ML
1#!/usr/bin/perl
2
3####
4#### This application is a CVS emulation layer for git.
5#### It is intended for clients to connect over SSH.
6#### See the documentation for more details.
7####
8#### Copyright The Open University UK - 2006.
9####
10#### Authors: Martyn Smith <martyn@catalyst.net.nz>
adc3192e 11#### Martin Langhoff <martin@laptop.org>
3fda8c4c
ML
12####
13####
14#### Released under the GNU Public License, version 2.
15####
16####
17
d48b2841 18use 5.008;
3fda8c4c
ML
19use strict;
20use warnings;
4f88d3e0 21use bytes;
3fda8c4c
ML
22
23use Fcntl;
24use File::Temp qw/tempdir tempfile/;
044182ef 25use File::Path qw/rmtree/;
3fda8c4c 26use File::Basename;
693b6327
FL
27use Getopt::Long qw(:config require_order no_ignore_case);
28
29my $VERSION = '@@GIT_VERSION@@';
3fda8c4c
ML
30
31my $log = GITCVS::log->new();
32my $cfg;
33
34my $DATE_LIST = {
35 Jan => "01",
36 Feb => "02",
37 Mar => "03",
38 Apr => "04",
39 May => "05",
40 Jun => "06",
41 Jul => "07",
42 Aug => "08",
43 Sep => "09",
44 Oct => "10",
45 Nov => "11",
46 Dec => "12",
47};
48
49# Enable autoflush for STDOUT (otherwise the whole thing falls apart)
50$| = 1;
51
52#### Definition and mappings of functions ####
53
566c69e7
MO
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?
3fda8c4c
ML
58my $methods = {
59 'Root' => \&req_Root,
60 'Valid-responses' => \&req_Validresponses,
61 'valid-requests' => \&req_validrequests,
62 'Directory' => \&req_Directory,
eb5dcb2c 63 'Sticky' => \&req_Sticky,
3fda8c4c
ML
64 'Entry' => \&req_Entry,
65 'Modified' => \&req_Modified,
66 'Unchanged' => \&req_Unchanged,
7172aabb 67 'Questionable' => \&req_Questionable,
3fda8c4c
ML
68 'Argument' => \&req_Argument,
69 'Argumentx' => \&req_Argument,
70 'expand-modules' => \&req_expandmodules,
71 'add' => \&req_add,
72 'remove' => \&req_remove,
73 'co' => \&req_co,
74 'update' => \&req_update,
75 'ci' => \&req_ci,
76 'diff' => \&req_diff,
77 'log' => \&req_log,
7172aabb 78 'rlog' => \&req_log,
3fda8c4c
ML
79 'tag' => \&req_CATCHALL,
80 'status' => \&req_status,
81 'admin' => \&req_CATCHALL,
82 'history' => \&req_CATCHALL,
38bcd31a
DD
83 'watchers' => \&req_EMPTY,
84 'editors' => \&req_EMPTY,
499cc56a 85 'noop' => \&req_EMPTY,
3fda8c4c
ML
86 'annotate' => \&req_annotate,
87 'Global_option' => \&req_Globaloption,
3fda8c4c
ML
88};
89
90##############################################
91
92
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.
42217f13 95my $state = { prependdir => '' };
044182ef
MO
96
97# Work is for managing temporary working directory
98my $work =
99 {
100 state => undef, # undef, 1 (empty), 2 (with stuff)
101 workDir => undef,
102 index => undef,
103 emptyDir => undef,
104 tmpDir => undef
105 };
106
3fda8c4c
ML
107$log->info("--------------- STARTING -----------------");
108
693b6327 109my $usage =
d2bb624c 110 "usage: git cvsserver [options] [pserver|server] [<directory> ...]\n".
693b6327 111 " --base-path <path> : Prepend to requested CVSROOT\n".
03bd0d60 112 " Can be read from GIT_CVSSERVER_BASE_PATH\n".
693b6327
FL
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".
87182b17 116 " -h, -H : Print usage information and exit\n".
693b6327
FL
117 "\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".
03bd0d60
PM
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";
693b6327 122
87182b17 123my @opts = ( 'h|H', 'version|V',
693b6327
FL
124 'base-path=s', 'strict-paths', 'export-all' );
125GetOptions( $state, @opts )
126 or die $usage;
127
128if ($state->{version}) {
129 print "git-cvsserver version $VERSION\n";
130 exit;
131}
132if ($state->{help}) {
133 print $usage;
134 exit;
135}
136
3fda8c4c
ML
137my $TEMP_DIR = tempdir( CLEANUP => 1 );
138$log->debug("Temporary directory is '$TEMP_DIR'");
139
693b6327
FL
140$state->{method} = 'ext';
141if (@ARGV) {
142 if ($ARGV[0] eq 'pserver') {
143 $state->{method} = 'pserver';
144 shift @ARGV;
145 } elsif ($ARGV[0] eq 'server') {
146 shift @ARGV;
147 }
148}
149
150# everything else is a directory
151$state->{allowed_roots} = [ @ARGV ];
152
226bccb9
FL
153# don't export the whole system unless the users requests it
154if ($state->{'export-all'} && !@{$state->{allowed_roots}}) {
155 die "--export-all can only be used together with an explicit whitelist\n";
156}
157
03bd0d60
PM
158# Environment handling for running under git-shell
159if (exists $ENV{GIT_CVSSERVER_BASE_PATH}) {
160 if ($state->{'base-path'}) {
161 die "Cannot specify base path both ways.\n";
162 }
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");
166}
167if (exists $ENV{GIT_CVSSERVER_ROOT}) {
168 if (@{$state->{allowed_roots}}) {
169 die "Cannot specify roots both ways: @ARGV\n";
170 }
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");
174}
175
91a6bf46 176# if we are called with a pserver argument,
5348b6e7 177# deal with the authentication cat before entering the
91a6bf46 178# main loop
693b6327 179if ($state->{method} eq 'pserver') {
91a6bf46 180 my $line = <STDIN>; chomp $line;
24a97d84 181 unless( $line =~ /^BEGIN (AUTH|VERIFICATION) REQUEST$/) {
91a6bf46
ML
182 die "E Do not understand $line - expecting BEGIN AUTH REQUEST\n";
183 }
24a97d84 184 my $request = $1;
91a6bf46 185 $line = <STDIN>; chomp $line;
2a4b5d5a
BG
186 unless (req_Root('root', $line)) { # reuse Root
187 print "E Invalid root $line \n";
188 exit 1;
189 }
91a6bf46 190 $line = <STDIN>; chomp $line;
031a027a
ÆAB
191 my $user = $line;
192 $line = <STDIN>; chomp $line;
193 my $password = $line;
194
475357a3
ÆAB
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";
201 exit 1;
202 }
203
204 # Fall through to LOVE
205 } else {
031a027a 206 # Trying to authenticate a user
c057bad3 207 if (not exists $cfg->{gitcvs}->{authdb}) {
475357a3
ÆAB
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";
210 exit 1;
211 }
212
213 my $authdb = $cfg->{gitcvs}->{authdb};
214
215 unless (-e $authdb) {
216 print "E The authentication database specified in [gitcvs.authdb] does not exist\n";
031a027a
ÆAB
217 print "I HATE YOU\n";
218 exit 1;
c057bad3 219 }
3052525e
ÆAB
220
221 my $auth_ok;
475357a3 222 open my $passwd, "<", $authdb or die $!;
3052525e
ÆAB
223 while (<$passwd>) {
224 if (m{^\Q$user\E:(.*)}) {
475357a3 225 if (crypt($user, descramble($password)) eq $1) {
3052525e
ÆAB
226 $auth_ok = 1;
227 }
228 };
229 }
230 close $passwd;
231
232 unless ($auth_ok) {
031a027a
ÆAB
233 print "I HATE YOU\n";
234 exit 1;
031a027a 235 }
475357a3
ÆAB
236
237 # Fall through to LOVE
91a6bf46 238 }
031a027a
ÆAB
239
240 # For checking whether the user is anonymous on commit
241 $state->{user} = $user;
242
91a6bf46 243 $line = <STDIN>; chomp $line;
24a97d84
FL
244 unless ($line eq "END $request REQUEST") {
245 die "E Do not understand $line -- expecting END $request REQUEST\n";
91a6bf46
ML
246 }
247 print "I LOVE YOU\n";
24a97d84 248 exit if $request eq 'VERIFICATION'; # cvs login
91a6bf46
ML
249 # and now back to our regular programme...
250}
251
3fda8c4c
ML
252# Keep going until the client closes the connection
253while (<STDIN>)
254{
255 chomp;
256
5348b6e7 257 # Check to see if we've seen this method, and call appropriate function.
3fda8c4c
ML
258 if ( /^([\w-]+)(?:\s+(.*))?$/ and defined($methods->{$1}) )
259 {
260 # use the $methods hash to call the appropriate sub for this command
261 #$log->info("Method : $1");
262 &{$methods->{$1}}($1,$2);
263 } else {
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 $_");
270 }
271}
272
273$log->debug("Processing time : user=" . (times)[0] . " system=" . (times)[1]);
274$log->info("--------------- FINISH -----------------");
275
044182ef
MO
276chdir '/';
277exit 0;
278
3fda8c4c
ML
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.
283sub req_CATCHALL
284{
285 my ( $cmd, $data ) = @_;
286 $log->warn("Unhandled command : req_$cmd : $data");
287}
288
38bcd31a
DD
289# This method invariably succeeds with an empty response.
290sub req_EMPTY
291{
292 print "ok\n";
293}
3fda8c4c
ML
294
295# Root pathname \n
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.
304sub req_Root
305{
306 my ( $cmd, $data ) = @_;
307 $log->debug("req_Root : $data");
308
4890888d
FL
309 unless ($data =~ m#^/#) {
310 print "error 1 Root must be an absolute pathname\n";
311 return 0;
312 }
313
fd1cd91e
FL
314 my $cvsroot = $state->{'base-path'} || '';
315 $cvsroot =~ s#/+$##;
316 $cvsroot .= $data;
317
4890888d 318 if ($state->{CVSROOT}
fd1cd91e 319 && ($state->{CVSROOT} ne $cvsroot)) {
4890888d
FL
320 print "error 1 Conflicting roots specified\n";
321 return 0;
322 }
323
fd1cd91e 324 $state->{CVSROOT} = $cvsroot;
3fda8c4c
ML
325
326 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
693b6327
FL
327
328 if (@{$state->{allowed_roots}}) {
329 my $allowed = 0;
330 foreach my $dir (@{$state->{allowed_roots}}) {
331 next unless $dir =~ m#^/#;
332 $dir =~ s#/+$##;
333 if ($state->{'strict-paths'}) {
334 if ($ENV{GIT_DIR} =~ m#^\Q$dir\E/?$#) {
335 $allowed = 1;
336 last;
337 }
338 } elsif ($ENV{GIT_DIR} =~ m#^\Q$dir\E(/?$|/)#) {
339 $allowed = 1;
340 last;
341 }
342 }
343
344 unless ($allowed) {
345 print "E $ENV{GIT_DIR} does not seem to be a valid GIT repository\n";
346 print "E \n";
347 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
348 return 0;
349 }
350 }
351
cdb6760e
ML
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";
693b6327
FL
354 print "E \n";
355 print "error 1 $ENV{GIT_DIR} is not a valid repository\n";
cdb6760e
ML
356 return 0;
357 }
3fda8c4c 358
46203ac2 359 my @gitvars = safe_pipe_capture(qw(git config -l));
cdb6760e 360 if ($?) {
e0d10e1c 361 print "E problems executing git-config on the server -- this is not a git repository or the PATH is not set correctly.\n";
cdb6760e 362 print "E \n";
e0d10e1c 363 print "error 1 - problem executing git-config\n";
cdb6760e
ML
364 return 0;
365 }
366 foreach my $line ( @gitvars )
3fda8c4c 367 {
c057bad3 368 next unless ( $line =~ /^(gitcvs)\.(?:(ext|pserver)\.)?([\w-]+)=(.*)$/ );
f987afa8
FL
369 unless ($2) {
370 $cfg->{$1}{$3} = $4;
92a39a14
FL
371 } else {
372 $cfg->{$1}{$2}{$3} = $4;
373 }
3fda8c4c
ML
374 }
375
523d12e5
JH
376 my $enabled = ($cfg->{gitcvs}{$state->{method}}{enabled}
377 || $cfg->{gitcvs}{enabled});
226bccb9
FL
378 unless ($state->{'export-all'} ||
379 ($enabled && $enabled =~ /^\s*(1|true|yes)\s*$/i)) {
3fda8c4c
ML
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";
382 print "E \n";
383 print "error 1 GITCVS emulation disabled\n";
91a6bf46 384 return 0;
3fda8c4c
ML
385 }
386
d55820ce
FL
387 my $logfile = $cfg->{gitcvs}{$state->{method}}{logfile} || $cfg->{gitcvs}{logfile};
388 if ( $logfile )
3fda8c4c 389 {
d55820ce 390 $log->setfile($logfile);
3fda8c4c
ML
391 } else {
392 $log->nofile();
393 }
91a6bf46
ML
394
395 return 1;
3fda8c4c
ML
396}
397
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
404# request.
405sub req_Globaloption
406{
407 my ( $cmd, $data ) = @_;
408 $log->debug("req_Globaloption : $data");
7d90095a 409 $state->{globaloptions}{$data} = 1;
3fda8c4c
ML
410}
411
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.
415sub req_Validresponses
416{
417 my ( $cmd, $data ) = @_;
5348b6e7 418 $log->debug("req_Validresponses : $data");
3fda8c4c
ML
419
420 # TODO : re-enable this, currently it's not particularly useful
421 #$state->{validresponses} = [ split /\s+/, $data ];
422}
423
424# valid-requests \n
425# Response expected: yes. Ask the server to send back a Valid-requests
426# response.
427sub req_validrequests
428{
429 my ( $cmd, $data ) = @_;
430
431 $log->debug("req_validrequests");
432
9462953a 433 $log->debug("SEND : Valid-requests " . join(" ",sort keys %$methods));
3fda8c4c
ML
434 $log->debug("SEND : ok");
435
9462953a 436 print "Valid-requests " . join(" ",sort keys %$methods) . "\n";
3fda8c4c
ML
437 print "ok\n";
438}
439
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
450# local-directory.
451sub req_Directory
452{
453 my ( $cmd, $data ) = @_;
454
455 my $repository = <STDIN>;
456 chomp $repository;
457
458
459 $state->{localdir} = $data;
460 $state->{repository} = $repository;
7d90095a 461 $state->{path} = $repository;
f9acaeae 462 $state->{path} =~ s/^\Q$state->{CVSROOT}\E\///;
7d90095a
MS
463 $state->{module} = $1 if ($state->{path} =~ s/^(.*?)(\/|$)//);
464 $state->{path} .= "/" if ( $state->{path} =~ /\S/ );
465
466 $state->{directory} = $state->{localdir};
467 $state->{directory} = "" if ( $state->{directory} eq "." );
3fda8c4c
ML
468 $state->{directory} .= "/" if ( $state->{directory} =~ /\S/ );
469
d988b822 470 if ( (not defined($state->{prependdir}) or $state->{prependdir} eq '') and $state->{localdir} eq "." and $state->{path} =~ /\S/ )
7d90095a
MS
471 {
472 $log->info("Setting prepend to '$state->{path}'");
473 $state->{prependdir} = $state->{path};
eb5dcb2c 474 my %entries;
7d90095a
MS
475 foreach my $entry ( keys %{$state->{entries}} )
476 {
eb5dcb2c 477 $entries{$state->{prependdir} . $entry} = $state->{entries}{$entry};
7d90095a 478 }
eb5dcb2c
MO
479 $state->{entries}=\%entries;
480
481 my %dirMap;
482 foreach my $dir ( keys %{$state->{dirMap}} )
483 {
484 $dirMap{$state->{prependdir} . $dir} = $state->{dirMap}{$dir};
485 }
486 $state->{dirMap}=\%dirMap;
7d90095a
MS
487 }
488
489 if ( defined ( $state->{prependdir} ) )
490 {
491 $log->debug("Prepending '$state->{prependdir}' to state|directory");
492 $state->{directory} = $state->{prependdir} . $state->{directory}
493 }
eb5dcb2c
MO
494
495 if ( ! defined($state->{dirMap}{$state->{directory}}) )
496 {
497 $state->{dirMap}{$state->{directory}} =
498 {
499 'names' => {}
500 #'tagspec' => undef
501 };
502 }
503
82000d74 504 $log->debug("req_Directory : localdir=$data repository=$repository path=$state->{path} directory=$state->{directory} module=$state->{module}");
3fda8c4c
ML
505}
506
eb5dcb2c
MO
507# Sticky tagspec \n
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
514# by Set-sticky.
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.
520sub req_Sticky
521{
522 my ( $cmd, $tagspec ) = @_;
523
524 my ( $stickyInfo );
525 if($tagspec eq "")
526 {
527 # nothing
528 }
529 elsif($tagspec=~/^T([^ ]+)\s*$/)
530 {
531 $stickyInfo = { 'tag' => $1 };
532 }
533 elsif($tagspec=~/^D([0-9.]+)\s*$/)
534 {
535 $stickyInfo= { 'date' => $1 };
536 }
537 else
538 {
539 die "Unknown tag_or_date format\n";
540 }
541 $state->{dirMap}{$state->{directory}}{stickyInfo}=$stickyInfo;
542
543 $log->debug("req_Sticky : tagspec=$tagspec repository=$state->{repository}"
544 . " path=$state->{path} directory=$state->{directory}"
545 . " module=$state->{module}");
546}
547
3fda8c4c
ML
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
558# of these three.
559sub req_Entry
560{
561 my ( $cmd, $data ) = @_;
562
7d90095a 563 #$log->debug("req_Entry : $data");
3fda8c4c 564
abd66f22 565 my @data = split(/\//, $data, -1);
3fda8c4c
ML
566
567 $state->{entries}{$state->{directory}.$data[1]} = {
568 revision => $data[2],
569 conflict => $data[3],
570 options => $data[4],
571 tag_or_date => $data[5],
572 };
7d90095a 573
eb5dcb2c
MO
574 $state->{dirMap}{$state->{directory}}{names}{$data[1]} = 'F';
575
7d90095a
MS
576 $log->info("Received entry line '$data' => '" . $state->{directory} . $data[1] . "'");
577}
578
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.
585sub req_Questionable
586{
587 my ( $cmd, $data ) = @_;
588
589 $log->debug("req_Questionable : $data");
590 $state->{entries}{$state->{directory}.$data}{questionable} = 1;
3fda8c4c
ML
591}
592
593# add \n
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.
599sub req_add
600{
601 my ( $cmd, $data ) = @_;
602
603 argsplit("add");
604
4db0c8de
FL
605 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
606 $updater->update();
607
3fda8c4c
ML
608 my $addcount = 0;
609
610 foreach my $filename ( @{$state->{args}} )
611 {
612 $filename = filecleanup($filename);
613
61717661
MO
614 # no -r, -A, or -D with add
615 my $stickyInfo = resolveStickyInfo($filename);
616
617 my $meta = $updater->getmeta($filename,$stickyInfo);
4db0c8de
FL
618 my $wrev = revparse($filename);
619
ab07681f 620 if ($wrev && $meta && ($wrev=~/^-/))
4db0c8de
FL
621 {
622 # previously removed file, add back
ab07681f 623 $log->info("added file $filename was previously removed, send $meta->{revision}");
4db0c8de
FL
624
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";
630
631 unless ( $state->{globaloptions}{-n} )
632 {
633 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
634
635 print "Created $dirpart\n";
636 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
637
638 # this is an "entries" line
90948a42 639 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661
MO
640 my $entryLine = "/$filepart/$meta->{revision}//$kopts/";
641 $entryLine .= getStickyTagOrDate($stickyInfo);
642 $log->debug($entryLine);
643 print "$entryLine\n";
4db0c8de
FL
644 # permissions
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";
647 # transmit file
648 transmitfile($meta->{filehash});
649 }
650
651 next;
652 }
653
3fda8c4c
ML
654 unless ( defined ( $state->{entries}{$filename}{modified_filename} ) )
655 {
656 print "E cvs add: nothing known about `$filename'\n";
657 next;
658 }
659 # TODO : check we're not squashing an already existing file
660 if ( defined ( $state->{entries}{$filename}{revision} ) )
661 {
662 print "E cvs add: `$filename' has already been entered\n";
663 next;
664 }
665
7d90095a 666 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
3fda8c4c
ML
667
668 print "E cvs add: scheduling file `$filename' for addition\n";
669
670 print "Checked-in $dirpart\n";
671 print "$filename\n";
90948a42
MO
672 my $kopts = kopts_from_path($filename,"file",
673 $state->{entries}{$filename}{modified_filename});
61717661
MO
674 print "/$filepart/0//$kopts/" .
675 getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c 676
8a06a632
MO
677 my $requestedKopts = $state->{opt}{k};
678 if(defined($requestedKopts))
679 {
680 $requestedKopts = "-k$requestedKopts";
681 }
682 else
683 {
684 $requestedKopts = "";
685 }
686 if( $kopts ne $requestedKopts )
687 {
688 $log->warn("Ignoring requested -k='$requestedKopts'"
689 . " for '$filename'; detected -k='$kopts' instead");
690 #TODO: Also have option to send warning to user?
691 }
692
3fda8c4c
ML
693 $addcount++;
694 }
695
696 if ( $addcount == 1 )
697 {
698 print "E cvs add: use `cvs commit' to add this file permanently\n";
699 }
700 elsif ( $addcount > 1 )
701 {
702 print "E cvs add: use `cvs commit' to add these files permanently\n";
703 }
704
705 print "ok\n";
706}
707
708# remove \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.
719sub req_remove
720{
721 my ( $cmd, $data ) = @_;
722
723 argsplit("remove");
724
725 # Grab a handle to the SQLite db and do any necessary updates
726 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
727 $updater->update();
728
729 #$log->debug("add state : " . Dumper($state));
730
731 my $rmcount = 0;
732
733 foreach my $filename ( @{$state->{args}} )
734 {
735 $filename = filecleanup($filename);
736
737 if ( defined ( $state->{entries}{$filename}{unchanged} ) or defined ( $state->{entries}{$filename}{modified_filename} ) )
738 {
739 print "E cvs remove: file `$filename' still in working directory\n";
740 next;
741 }
742
61717661
MO
743 # only from entries
744 my $stickyInfo = resolveStickyInfo($filename);
745
746 my $meta = $updater->getmeta($filename,$stickyInfo);
3fda8c4c
ML
747 my $wrev = revparse($filename);
748
749 unless ( defined ( $wrev ) )
750 {
751 print "E cvs remove: nothing known about `$filename'\n";
752 next;
753 }
754
ab07681f 755 if ( defined($wrev) and ($wrev=~/^-/) )
3fda8c4c
ML
756 {
757 print "E cvs remove: file `$filename' already scheduled for removal\n";
758 next;
759 }
760
ab07681f 761 unless ( $wrev eq $meta->{revision} )
3fda8c4c
ML
762 {
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";
765 next;
766 }
767
768
7d90095a 769 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
3fda8c4c
ML
770
771 print "E cvs remove: scheduling `$filename' for removal\n";
772
773 print "Checked-in $dirpart\n";
774 print "$filename\n";
90948a42 775 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661 776 print "/$filepart/-$wrev//$kopts/" . getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c
ML
777
778 $rmcount++;
779 }
780
781 if ( $rmcount == 1 )
782 {
783 print "E cvs remove: use `cvs commit' to remove this file permanently\n";
784 }
785 elsif ( $rmcount > 1 )
786 {
787 print "E cvs remove: use `cvs commit' to remove these files permanently\n";
788 }
789
790 print "ok\n";
791}
792
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.
800sub req_Modified
801{
802 my ( $cmd, $data ) = @_;
803
804 my $mode = <STDIN>;
a5e40798
JM
805 defined $mode
806 or (print "E end of file reading mode for $data\n"), return;
3fda8c4c
ML
807 chomp $mode;
808 my $size = <STDIN>;
a5e40798
JM
809 defined $size
810 or (print "E end of file reading size of $data\n"), return;
3fda8c4c
ML
811 chomp $size;
812
813 # Grab config information
814 my $blocksize = 8192;
815 my $bytesleft = $size;
816 my $tmp;
817
818 # Get a filehandle/name to write it to
819 my ( $fh, $filename ) = tempfile( DIR => $TEMP_DIR );
820
821 # Loop over file data writing out to temporary file.
822 while ( $bytesleft )
823 {
824 $blocksize = $bytesleft if ( $bytesleft < $blocksize );
825 read STDIN, $tmp, $blocksize;
826 print $fh $tmp;
827 $bytesleft -= $blocksize;
828 }
829
a5e40798
JM
830 close $fh
831 or (print "E failed to write temporary, $filename: $!\n"), return;
3fda8c4c
ML
832
833 # Ensure we have something sensible for the file mode
834 if ( $mode =~ /u=(\w+)/ )
835 {
836 $mode = $1;
837 } else {
838 $mode = "rw";
839 }
840
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;
27dd7387 844 $state->{entries}{$state->{directory}.$data}{modified_hash} = safe_pipe_capture('git','hash-object',$filename);
3fda8c4c
ML
845 $state->{entries}{$state->{directory}.$data}{modified_hash} =~ s/\s.*$//s;
846
847 #$log->debug("req_Modified : file=$data mode=$mode size=$size");
848}
849
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 `/'.
854sub req_Unchanged
855{
856 my ( $cmd, $data ) = @_;
857
858 $state->{entries}{$state->{directory}.$data}{unchanged} = 1;
859
860 #$log->debug("req_Unchanged : $data");
861}
862
863# Argument text \n
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.
867# Argumentx text \n
868# Response expected: no. Append \n followed by text to the current argument
869# being saved.
870sub req_Argument
871{
872 my ( $cmd, $data ) = @_;
873
2c3cff49 874 # Argumentx means: append to last Argument (with a newline in front)
3fda8c4c
ML
875
876 $log->debug("$cmd : $data");
877
2c3cff49
JS
878 if ( $cmd eq 'Argumentx') {
879 ${$state->{arguments}}[$#{$state->{arguments}}] .= "\n" . $data;
880 } else {
881 push @{$state->{arguments}}, $data;
882 }
3fda8c4c
ML
883}
884
885# expand-modules \n
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:
907sub req_expandmodules
908{
909 my ( $cmd, $data ) = @_;
910
911 argsplit();
912
913 $log->debug("req_expandmodules : " . ( defined($data) ? $data : "[NULL]" ) );
914
915 unless ( ref $state->{arguments} eq "ARRAY" )
916 {
917 print "ok\n";
918 return;
919 }
920
921 foreach my $module ( @{$state->{arguments}} )
922 {
923 $log->debug("SEND : Module-expansion $module");
924 print "Module-expansion $module\n";
925 }
926
927 print "ok\n";
928 statecleanup();
929}
930
931# co \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.
938sub req_co
939{
940 my ( $cmd, $data ) = @_;
941
942 argsplit("co");
943
89a9167f
LN
944 # Provide list of modules, if -c was used.
945 if (exists $state->{opt}{c}) {
46203ac2 946 my $showref = safe_pipe_capture(qw(git show-ref --heads));
89a9167f
LN
947 for my $line (split '\n', $showref) {
948 if ( $line =~ m% refs/heads/(.*)$% ) {
949 print "M $1\t$1\n";
950 }
951 }
952 print "ok\n";
953 return 1;
954 }
955
61717661
MO
956 my $stickyInfo = { 'tag' => $state->{opt}{r},
957 'date' => $state->{opt}{D} };
958
3fda8c4c 959 my $module = $state->{args}[0];
8a06a632 960 $state->{module} = $module;
3fda8c4c
ML
961 my $checkout_path = $module;
962
963 # use the user specified directory if we're given it
964 $checkout_path = $state->{opt}{d} if ( exists ( $state->{opt}{d} ) );
965
966 $log->debug("req_co : " . ( defined($data) ? $data : "[NULL]" ) );
967
968 $log->info("Checking out module '$module' ($state->{CVSROOT}) to '$checkout_path'");
969
970 $ENV{GIT_DIR} = $state->{CVSROOT} . "/";
971
972 # Grab a handle to the SQLite db and do any necessary updates
973 my $updater = GITCVS::updater->new($state->{CVSROOT}, $module, $log);
974 $updater->update();
975
61717661
MO
976 my $headHash;
977 if( defined($stickyInfo) && defined($stickyInfo->{tag}) )
978 {
979 $headHash = $updater->lookupCommitRef($stickyInfo->{tag});
980 if( !defined($headHash) )
981 {
982 print "error 1 no such tag `$stickyInfo->{tag}'\n";
983 cleanupWorkTree();
984 exit;
985 }
986 }
c8c4f220 987
61717661 988 $checkout_path =~ s|/$||; # get rid of trailing slashes
c8c4f220
ML
989
990 my %seendirs = ();
501c7372 991 my $lastdir ='';
3fda8c4c 992
61717661
MO
993 prepDirForOutput(
994 ".",
995 $state->{CVSROOT} . "/$module",
996 $checkout_path,
997 \%seendirs,
998 'checkout',
999 $state->{dirArgs} );
1000
1001 foreach my $git ( @{$updater->getAnyHead($headHash)} )
3fda8c4c
ML
1002 {
1003 # Don't want to check out deleted files
1004 next if ( $git->{filehash} eq "deleted" );
1005
8a06a632 1006 my $fullName = $git->{name};
3fda8c4c
ML
1007 ( $git->{name}, $git->{dir} ) = filenamesplit($git->{name});
1008
61717661
MO
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;
1015 }
6be32d47 1016
3fda8c4c
ML
1017 # modification time of this file
1018 print "Mod-time $git->{modified}\n";
1019
1020 # print some information to the client
3fda8c4c
ML
1021 if ( defined ( $git->{dir} ) and $git->{dir} ne "./" )
1022 {
c8c4f220 1023 print "M U $checkout_path/$git->{dir}$git->{name}\n";
3fda8c4c 1024 } else {
c8c4f220 1025 print "M U $checkout_path/$git->{name}\n";
3fda8c4c 1026 }
c8c4f220 1027
6be32d47
ML
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";
3fda8c4c 1030
6be32d47 1031 print $state->{CVSROOT} . "/$module/" . ( defined ( $git->{dir} ) and $git->{dir} ne "./" ? $git->{dir} . "/" : "" ) . "$git->{name}\n";
3fda8c4c
ML
1032
1033 # this is an "entries" line
90948a42 1034 my $kopts = kopts_from_path($fullName,"sha1",$git->{filehash});
61717661
MO
1035 print "/$git->{name}/$git->{revision}//$kopts/" .
1036 getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c
ML
1037 # permissions
1038 print "u=$git->{mode},g=$git->{mode},o=$git->{mode}\n";
1039
1040 # transmit file
1041 transmitfile($git->{filehash});
1042 }
1043
1044 print "ok\n";
1045
1046 statecleanup();
1047}
1048
61717661
MO
1049# used by req_co and req_update to set up directories for files
1050# recursively handles parents
1051sub prepDirForOutput
1052{
1053 my ($dir, $repodir, $remotedir, $seendirs, $request, $dirArgs) = @_;
1054
1055 my $parent = dirname($dir);
1056 $dir =~ s|/+$||;
1057 $repodir =~ s|/+$||;
1058 $remotedir =~ s|/+$||;
1059 $parent =~ s|/+$||;
1060
1061 if ($parent eq '.' || $parent eq './')
1062 {
1063 $parent = '';
1064 }
1065 # recurse to announce unseen parents first
1066 if( length($parent) &&
1067 !exists($seendirs->{$parent}) &&
1068 ( $request eq "checkout" ||
1069 exists($dirArgs->{$parent}) ) )
1070 {
1071 prepDirForOutput($parent, $repodir, $remotedir,
1072 $seendirs, $request, $dirArgs);
1073 }
1074 # Announce that we are going to modify at the parent level
1075 if ($dir eq '.' || $dir eq './')
1076 {
1077 $dir = '';
1078 }
1079 if(exists($seendirs->{$dir}))
1080 {
1081 return;
1082 }
1083 $log->debug("announcedir $dir, $repodir, $remotedir" );
1084 my($thisRemoteDir,$thisRepoDir);
1085 if ($dir ne "")
1086 {
1087 $thisRepoDir="$repodir/$dir";
1088 if($remotedir eq ".")
1089 {
1090 $thisRemoteDir=$dir;
1091 }
1092 else
1093 {
1094 $thisRemoteDir="$remotedir/$dir";
1095 }
1096 }
1097 else
1098 {
1099 $thisRepoDir=$repodir;
1100 $thisRemoteDir=$remotedir;
1101 }
1102 unless ( $state->{globaloptions}{-Q} || $state->{globaloptions}{-q} )
1103 {
1104 print "E cvs $request: Updating $thisRemoteDir\n";
1105 }
1106
1107 my ($opt_r)=$state->{opt}{r};
1108 my $stickyInfo;
1109 if(exists($state->{opt}{A}))
1110 {
1111 # $stickyInfo=undef;
1112 }
1113 elsif( defined($opt_r) && $opt_r ne "" )
1114 # || ( defined($state->{opt}{D}) && $state->{opt}{D} ne "" ) # TODO
1115 {
1116 $stickyInfo={ 'tag' => (defined($opt_r)?$opt_r:undef) };
1117
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) };
1123 }
1124 else
1125 {
1126 $stickyInfo=getDirStickyInfo($state->{prependdir} . $dir);
1127 }
1128
1129 my $stickyResponse;
1130 if(defined($stickyInfo))
1131 {
1132 $stickyResponse = "Set-sticky $thisRemoteDir/\n" .
1133 "$thisRepoDir/\n" .
1134 getStickyTagOrDate($stickyInfo) . "\n";
1135 }
1136 else
1137 {
1138 $stickyResponse = "Clear-sticky $thisRemoteDir/\n" .
1139 "$thisRepoDir/\n";
1140 }
1141
1142 unless ( $state->{globaloptions}{-n} )
1143 {
1144 print $stickyResponse;
1145
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";
1151 print "0\n";
1152 }
1153
1154 $seendirs->{$dir} = 1;
1155
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
832c0e5e 1159 # $seendirs after processing all files.
61717661
MO
1160}
1161
3fda8c4c
ML
1162# update \n
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.
1169sub req_update
1170{
1171 my ( $cmd, $data ) = @_;
1172
1173 $log->debug("req_update : " . ( defined($data) ? $data : "[NULL]" ));
1174
1175 argsplit("update");
1176
858cbfba 1177 #
5348b6e7 1178 # It may just be a client exploring the available heads/modules
858cbfba
ML
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.
1182 #
1183 if ($state->{module} eq '') {
46203ac2 1184 my $showref = safe_pipe_capture(qw(git show-ref --heads));
858cbfba 1185 print "E cvs update: Updating .\n";
b20171eb
LN
1186 for my $line (split '\n', $showref) {
1187 if ( $line =~ m% refs/heads/(.*)$% ) {
1188 print "E cvs update: New directory `$1'\n";
1189 }
1190 }
1191 print "ok\n";
1192 return 1;
858cbfba
ML
1193 }
1194
1195
3fda8c4c
ML
1196 # Grab a handle to the SQLite db and do any necessary updates
1197 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1198
1199 $updater->update();
1200
7d90095a 1201 argsfromdir($updater);
3fda8c4c
ML
1202
1203 #$log->debug("update state : " . Dumper($state));
1204
61717661
MO
1205 my($repoDir);
1206 $repoDir=$state->{CVSROOT} . "/$state->{module}/$state->{prependdir}";
1207
1208 my %seendirs = ();
8e4c4e7d 1209
addf88e4 1210 # foreach file specified on the command line ...
61717661 1211 foreach my $argsFilename ( @{$state->{args}} )
3fda8c4c 1212 {
61717661
MO
1213 my $filename;
1214 $filename = filecleanup($argsFilename);
3fda8c4c 1215
7d90095a
MS
1216 $log->debug("Processing file $filename");
1217
3fda8c4c
ML
1218 # if we have a -C we should pretend we never saw modified stuff
1219 if ( exists ( $state->{opt}{C} ) )
1220 {
1221 delete $state->{entries}{$filename}{modified_hash};
1222 delete $state->{entries}{$filename}{modified_filename};
1223 $state->{entries}{$filename}{unchanged} = 1;
1224 }
1225
61717661
MO
1226 my $stickyInfo = resolveStickyInfo($filename,
1227 $state->{opt}{r},
1228 $state->{opt}{D},
1229 exists($state->{opt}{A}));
1230 my $meta = $updater->getmeta($filename, $stickyInfo);
3fda8c4c 1231
e78f69a3
DD
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});
1236
1237 transmitfile($meta->{filehash}, { print => 1 });
1238 }
1239
1240 next;
1241 }
1242
61717661
MO
1243 # Directories:
1244 prepDirForOutput(
1245 dirname($argsFilename),
1246 $repoDir,
1247 ".",
1248 \%seendirs,
1249 "update",
1250 $state->{dirArgs} );
1251
1252 my $wrev = revparse($filename);
1253
0a7a9a12
JS
1254 if ( ! defined $meta )
1255 {
1256 $meta = {
1257 name => $filename,
ab07681f 1258 revision => '0',
0a7a9a12
JS
1259 filehash => 'added'
1260 };
61717661
MO
1261 if($wrev ne "0")
1262 {
1263 $meta->{filehash}='deleted';
1264 }
0a7a9a12 1265 }
3fda8c4c
ML
1266
1267 my $oldmeta = $meta;
1268
3fda8c4c 1269 # If the working copy is an old revision, lets get that version too for comparison.
61717661
MO
1270 my $oldWrev=$wrev;
1271 if(defined($oldWrev))
3fda8c4c 1272 {
61717661
MO
1273 $oldWrev=~s/^-//;
1274 if($oldWrev ne $meta->{revision})
1275 {
1276 $oldmeta = $updater->getmeta($filename, $oldWrev);
1277 }
3fda8c4c
ML
1278 }
1279
1280 #$log->debug("Target revision is $meta->{revision}, current working revision is $wrev");
1281
ec58db15
ML
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})
ab07681f 1286 and $wrev eq $meta->{revision}
ec58db15
ML
1287 and $state->{entries}{$filename}{unchanged}
1288 and not exists ( $state->{opt}{C} ) );
1289
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})
ab07681f 1294 and $wrev eq $meta->{revision}
61717661 1295 and $wrev ne "0"
cb52d9a1 1296 and defined($state->{entries}{$filename}{modified_hash})
ec58db15
ML
1297 and not exists ( $state->{opt}{C} ) )
1298 {
1299 $log->info("Tell the client the file is modified");
0a7a9a12 1300 print "MT text M \n";
ec58db15
ML
1301 print "MT fname $filename\n";
1302 print "MT newline\n";
1303 next;
1304 }
3fda8c4c 1305
61717661 1306 if ( $meta->{filehash} eq "deleted" && $wrev ne "0" )
3fda8c4c 1307 {
d8574ff2
MO
1308 # TODO: If it has been modified in the sandbox, error out
1309 # with the appropriate message, rather than deleting a modified
1310 # file.
1311
7d90095a 1312 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
3fda8c4c
ML
1313
1314 $log->info("Removing '$filename' from working copy (no longer in the repo)");
1315
1316 print "E cvs update: `$filename' is no longer in the repository\n";
7d90095a
MS
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";
1321 }
3fda8c4c 1322 }
ec58db15 1323 elsif ( not defined ( $state->{entries}{$filename}{modified_hash} )
0a7a9a12
JS
1324 or $state->{entries}{$filename}{modified_hash} eq $oldmeta->{filehash}
1325 or $meta->{filehash} eq 'added' )
3fda8c4c 1326 {
0a7a9a12
JS
1327 # normal update, just send the new revision (either U=Update,
1328 # or A=Add, or R=Remove)
ab07681f 1329 if ( defined($wrev) && ($wrev=~/^-/) )
0a7a9a12
JS
1330 {
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";
1335 next;
1336 }
ab07681f
MO
1337 elsif ( (!defined($wrev) || $wrev eq '0') &&
1338 (!defined($meta->{revision}) || $meta->{revision} eq '0') )
0a7a9a12 1339 {
535514f1 1340 $log->info("Tell the client the file is scheduled for addition");
0a7a9a12
JS
1341 print "MT text A \n";
1342 print "MT fname $filename\n";
1343 print "MT newline\n";
1344 next;
1345
1346 }
1347 else {
ab07681f 1348 $log->info("UpdatingX3 '$filename' to ".$meta->{revision});
0a7a9a12
JS
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";
1354 }
3fda8c4c 1355
7d90095a
MS
1356 my ( $filepart, $dirpart ) = filenamesplit($filename,1);
1357
1358 # Don't want to actually _DO_ the update if -n specified
1359 unless ( $state->{globaloptions}{-n} )
1360 {
1361 if ( defined ( $wrev ) )
1362 {
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'");
1366 } else {
1367 # instruct client we're sending a file to put in this path as a new file
7d90095a
MS
1368
1369 $log->debug("Creating new file 'Created $dirpart'");
1370 print "Created $dirpart\n";
1371 }
1372 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
1373
1374 # this is an "entries" line
90948a42 1375 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661
MO
1376 my $entriesLine = "/$filepart/$meta->{revision}//$kopts/";
1377 $entriesLine .= getStickyTagOrDate($stickyInfo);
1378 $log->debug($entriesLine);
1379 print "$entriesLine\n";
7d90095a
MS
1380
1381 # permissions
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";
1384
1385 # transmit file
1386 transmitfile($meta->{filehash});
1387 }
3fda8c4c 1388 } else {
7d90095a 1389 my ( $filepart, $dirpart ) = filenamesplit($meta->{name},1);
3fda8c4c 1390
044182ef 1391 my $mergeDir = setupTmpDir();
3fda8c4c 1392
3fda8c4c 1393 my $file_local = $filepart . ".mine";
044182ef 1394 my $mergedFile = "$mergeDir/$file_local";
3fda8c4c
ML
1395 system("ln","-s",$state->{entries}{$filename}{modified_filename}, $file_local);
1396 my $file_old = $filepart . "." . $oldmeta->{revision};
e78f69a3 1397 transmitfile($oldmeta->{filehash}, { targetfile => $file_old });
3fda8c4c 1398 my $file_new = $filepart . "." . $meta->{revision};
e78f69a3 1399 transmitfile($meta->{filehash}, { targetfile => $file_new });
3fda8c4c
ML
1400
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");
ab07681f 1403 print "M Merging differences between $oldmeta->{revision} and $meta->{revision} into $filename\n";
3fda8c4c 1404
044182ef 1405 $log->debug("Temporary directory for merge is $mergeDir");
3fda8c4c 1406
c6b4fa96 1407 my $return = system("git", "merge-file", $file_local, $file_old, $file_new);
3fda8c4c
ML
1408 $return >>= 8;
1409
044182ef
MO
1410 cleanupTmpDir();
1411
3fda8c4c
ML
1412 if ( $return == 0 )
1413 {
1414 $log->info("Merged successfully");
1415 print "M M $filename\n";
53877846 1416 $log->debug("Merged $dirpart");
7d90095a
MS
1417
1418 # Don't want to actually _DO_ the update if -n specified
1419 unless ( $state->{globaloptions}{-n} )
1420 {
53877846 1421 print "Merged $dirpart\n";
7d90095a
MS
1422 $log->debug($state->{CVSROOT} . "/$state->{module}/$filename");
1423 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
90948a42
MO
1424 my $kopts = kopts_from_path("$dirpart/$filepart",
1425 "file",$mergedFile);
ab07681f 1426 $log->debug("/$filepart/$meta->{revision}//$kopts/");
61717661
MO
1427 my $entriesLine="/$filepart/$meta->{revision}//$kopts/";
1428 $entriesLine .= getStickyTagOrDate($stickyInfo);
1429 print "$entriesLine\n";
7d90095a 1430 }
3fda8c4c
ML
1431 }
1432 elsif ( $return == 1 )
1433 {
1434 $log->info("Merged with conflicts");
459bad77 1435 print "E cvs update: conflicts found in $filename\n";
3fda8c4c 1436 print "M C $filename\n";
7d90095a
MS
1437
1438 # Don't want to actually _DO_ the update if -n specified
1439 unless ( $state->{globaloptions}{-n} )
1440 {
53877846 1441 print "Merged $dirpart\n";
7d90095a 1442 print $state->{CVSROOT} . "/$state->{module}/$filename\n";
90948a42
MO
1443 my $kopts = kopts_from_path("$dirpart/$filepart",
1444 "file",$mergedFile);
61717661
MO
1445 my $entriesLine = "/$filepart/$meta->{revision}/+/$kopts/";
1446 $entriesLine .= getStickyTagOrDate($stickyInfo);
1447 print "$entriesLine\n";
7d90095a 1448 }
3fda8c4c
ML
1449 }
1450 else
1451 {
1452 $log->warn("Merge failed");
1453 next;
1454 }
1455
7d90095a
MS
1456 # Don't want to actually _DO_ the update if -n specified
1457 unless ( $state->{globaloptions}{-n} )
1458 {
1459 # permissions
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";
1462
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
27dd7387 1466 my $data = safe_pipe_capture('cat', $mergedFile);
7d90095a
MS
1467 $log->debug("File size : " . length($data));
1468 print length($data) . "\n";
1469 print $data;
1470 }
3fda8c4c
ML
1471 }
1472
1473 }
1474
61717661
MO
1475 # prepDirForOutput() any other existing directories unless they already
1476 # have the right sticky tag:
1477 unless ( $state->{globaloptions}{n} )
1478 {
1479 my $dir;
1480 foreach $dir (keys(%{$state->{dirMap}}))
1481 {
1482 if( ! $seendirs{$dir} &&
1483 exists($state->{dirArgs}{$dir}) )
1484 {
1485 my($oldTag);
1486 $oldTag=$state->{dirMap}{$dir}{tagspec};
1487
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...
1494 {
1495 next;
1496 }
1497
1498 prepDirForOutput(
1499 $dir,
1500 $repoDir,
1501 ".",
1502 \%seendirs,
1503 'update',
1504 $state->{dirArgs} );
1505 }
1506
1507 # TODO?: Consider sending a final duplicate Sticky response
1508 # to more closely mimic real CVS.
1509 }
1510 }
1511
3fda8c4c
ML
1512 print "ok\n";
1513}
1514
1515sub req_ci
1516{
1517 my ( $cmd, $data ) = @_;
1518
1519 argsplit("ci");
1520
1521 #$log->debug("State : " . Dumper($state));
1522
1523 $log->info("req_ci : " . ( defined($data) ? $data : "[NULL]" ));
1524
031a027a 1525 if ( $state->{method} eq 'pserver' and $state->{user} eq 'anonymous' )
91a6bf46 1526 {
031a027a 1527 print "error 1 anonymous user cannot commit via pserver\n";
044182ef 1528 cleanupWorkTree();
91a6bf46
ML
1529 exit;
1530 }
1531
3fda8c4c
ML
1532 if ( -e $state->{CVSROOT} . "/index" )
1533 {
568907f5 1534 $log->warn("file 'index' already exists in the git repository");
3fda8c4c 1535 print "error 1 Index already exists in git repo\n";
044182ef 1536 cleanupWorkTree();
3fda8c4c
ML
1537 exit;
1538 }
1539
3fda8c4c
ML
1540 # Grab a handle to the SQLite db and do any necessary updates
1541 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
1542 $updater->update();
1543
3fda8c4c 1544 my @committedfiles = ();
392e2817 1545 my %oldmeta;
61717661
MO
1546 my $stickyInfo;
1547 my $branchRef;
1548 my $parenthash;
3fda8c4c 1549
addf88e4 1550 # foreach file specified on the command line ...
3fda8c4c
ML
1551 foreach my $filename ( @{$state->{args}} )
1552 {
7d90095a 1553 my $committedfile = $filename;
3fda8c4c
ML
1554 $filename = filecleanup($filename);
1555
1556 next unless ( exists $state->{entries}{$filename}{modified_filename} or not $state->{entries}{$filename}{unchanged} );
1557
61717661
MO
1558 #####
1559 # Figure out which branch and parenthash we are committing
1560 # to, and setup worktree:
1561
1562 # should always come from entries:
1563 my $fileStickyInfo = resolveStickyInfo($filename);
1564 if( !defined($branchRef) )
1565 {
1566 $stickyInfo = $fileStickyInfo;
1567 if( defined($stickyInfo) &&
1568 ( defined($stickyInfo->{date}) ||
1569 !defined($stickyInfo->{tag}) ) )
1570 {
1571 print "error 1 cannot commit with sticky date for file `$filename'\n";
1572 cleanupWorkTree();
1573 exit;
1574 }
1575
1576 $branchRef = "refs/heads/$state->{module}";
1577 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1578 {
1579 $branchRef = "refs/heads/$stickyInfo->{tag}";
1580 }
1581
27dd7387 1582 $parenthash = safe_pipe_capture('git', 'show-ref', '-s', $branchRef);
61717661
MO
1583 chomp $parenthash;
1584 if ($parenthash !~ /^[0-9a-f]{40}$/)
1585 {
1586 if ( defined($stickyInfo) && defined($stickyInfo->{tag}) )
1587 {
1588 print "error 1 sticky tag `$stickyInfo->{tag}' for file `$filename' is not a branch\n";
1589 }
1590 else
1591 {
1592 print "error 1 pserver cannot find the current HEAD of module";
1593 }
1594 cleanupWorkTree();
1595 exit;
1596 }
1597
1598 setupWorkTree($parenthash);
1599
1600 $log->info("Lockless commit start, basing commit on '$work->{workDir}', index file is '$work->{index}'");
1601
1602 $log->info("Created index '$work->{index}' for head $state->{module} - exit status $?");
1603 }
1604 elsif( !refHashEqual($stickyInfo,$fileStickyInfo) )
1605 {
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";
1611 cleanupWorkTree();
1612 exit;
1613 }
1614
1615 #####
1616 # Process this file:
1617
1618 my $meta = $updater->getmeta($filename,$stickyInfo);
392e2817 1619 $oldmeta{$filename} = $meta;
3fda8c4c
ML
1620
1621 my $wrev = revparse($filename);
1622
1623 my ( $filepart, $dirpart ) = filenamesplit($filename);
1624
cdf63284 1625 # do a checkout of the file if it is part of this tree
3fda8c4c 1626 if ($wrev) {
d2feb01a 1627 system('git', 'checkout-index', '-f', '-u', $filename);
3fda8c4c
ML
1628 unless ($? == 0) {
1629 die "Error running git-checkout-index -f -u $filename : $!";
1630 }
1631 }
1632
1633 my $addflag = 0;
1634 my $rmflag = 0;
ab07681f 1635 $rmflag = 1 if ( defined($wrev) and ($wrev=~/^-/) );
3fda8c4c
ML
1636 $addflag = 1 unless ( -e $filename );
1637
1638 # Do up to date checking
ab07681f
MO
1639 unless ( $addflag or $wrev eq $meta->{revision} or
1640 ( $rmflag and $wrev eq "-$meta->{revision}" ) )
3fda8c4c
ML
1641 {
1642 # fail everything if an up to date check fails
1643 print "error 1 Up to date check failed for $filename\n";
044182ef 1644 cleanupWorkTree();
3fda8c4c
ML
1645 exit;
1646 }
1647
7d90095a 1648 push @committedfiles, $committedfile;
3fda8c4c
ML
1649 $log->info("Committing $filename");
1650
1651 system("mkdir","-p",$dirpart) unless ( -d $dirpart );
1652
1653 unless ( $rmflag )
1654 {
1655 $log->debug("rename $state->{entries}{$filename}{modified_filename} $filename");
1656 rename $state->{entries}{$filename}{modified_filename},$filename;
1657
1658 # Calculate modes to remove
1659 my $invmode = "";
1660 foreach ( qw (r w x) ) { $invmode .= $_ unless ( $state->{entries}{$filename}{modified_mode} =~ /$_/ ); }
1661
1662 $log->debug("chmod u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode . " $filename");
1663 system("chmod","u+" . $state->{entries}{$filename}{modified_mode} . "-" . $invmode, $filename);
1664 }
1665
1666 if ( $rmflag )
1667 {
1668 $log->info("Removing file '$filename'");
1669 unlink($filename);
d2feb01a 1670 system("git", "update-index", "--remove", $filename);
3fda8c4c
ML
1671 }
1672 elsif ( $addflag )
1673 {
1674 $log->info("Adding file '$filename'");
d2feb01a 1675 system("git", "update-index", "--add", $filename);
3fda8c4c 1676 } else {
ab07681f 1677 $log->info("UpdatingX2 file '$filename'");
d2feb01a 1678 system("git", "update-index", $filename);
3fda8c4c
ML
1679 }
1680 }
1681
1682 unless ( scalar(@committedfiles) > 0 )
1683 {
1684 print "E No files to commit\n";
1685 print "ok\n";
044182ef 1686 cleanupWorkTree();
3fda8c4c
ML
1687 return;
1688 }
1689
46203ac2 1690 my $treehash = safe_pipe_capture(qw(git write-tree));
3fda8c4c 1691 chomp $treehash;
3fda8c4c
ML
1692
1693 $log->debug("Treehash : $treehash, Parenthash : $parenthash");
1694
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} ) );
280514e1
FE
1698 if ( defined ( $cfg->{gitcvs}{commitmsgannotation} ) ) {
1699 if ($cfg->{gitcvs}{commitmsgannotation} !~ /^\s*$/ ) {
1700 print $msg_fh "\n\n".$cfg->{gitcvs}{commitmsgannotation}."\n"
1701 }
1702 } else {
1703 print $msg_fh "\n\nvia git-CVS emulator\n";
1704 }
3fda8c4c
ML
1705 close $msg_fh;
1706
27dd7387 1707 my $commithash = safe_pipe_capture('git', 'commit-tree', $treehash, '-p', $parenthash, '-F', $msg_filename);
1872adab 1708 chomp($commithash);
3fda8c4c
ML
1709 $log->info("Commit hash : $commithash");
1710
1711 unless ( $commithash =~ /[a-zA-Z0-9]{40}/ )
1712 {
1713 $log->warn("Commit failed (Invalid commit hash)");
1714 print "error 1 Commit failed (unknown reason)\n";
044182ef 1715 cleanupWorkTree();
3fda8c4c
ML
1716 exit;
1717 }
1718
cdf63284 1719 ### Emulate git-receive-pack by running hooks/update
61717661 1720 my @hook = ( $ENV{GIT_DIR}.'hooks/update', $branchRef,
b2741f63 1721 $parenthash, $commithash );
cdf63284
MW
1722 if( -x $hook[0] ) {
1723 unless( system( @hook ) == 0 )
b2741f63
AP
1724 {
1725 $log->warn("Commit failed (update hook declined to update ref)");
1726 print "error 1 Commit failed (update hook declined)\n";
044182ef 1727 cleanupWorkTree();
b2741f63
AP
1728 exit;
1729 }
1730 }
1731
cdf63284 1732 ### Update the ref
ada5ef3b 1733 if (system(qw(git update-ref -m), "cvsserver ci",
61717661 1734 $branchRef, $commithash, $parenthash)) {
ada5ef3b
JH
1735 $log->warn("update-ref for $state->{module} failed.");
1736 print "error 1 Cannot commit -- update first\n";
044182ef 1737 cleanupWorkTree();
ada5ef3b
JH
1738 exit;
1739 }
3fda8c4c 1740
cdf63284
MW
1741 ### Emulate git-receive-pack by running hooks/post-receive
1742 my $hook = $ENV{GIT_DIR}.'hooks/post-receive';
1743 if( -x $hook ) {
1744 open(my $pipe, "| $hook") || die "can't fork $!";
1745
1746 local $SIG{PIPE} = sub { die 'pipe broke' };
1747
61717661 1748 print $pipe "$parenthash $commithash $branchRef\n";
cdf63284
MW
1749
1750 close $pipe || die "bad pipe: $! $?";
1751 }
1752
ad8c3477
SK
1753 $updater->update();
1754
394d66d4
JH
1755 ### Then hooks/post-update
1756 $hook = $ENV{GIT_DIR}.'hooks/post-update';
1757 if (-x $hook) {
61717661 1758 system($hook, $branchRef);
394d66d4
JH
1759 }
1760
addf88e4 1761 # foreach file specified on the command line ...
3fda8c4c
ML
1762 foreach my $filename ( @committedfiles )
1763 {
1764 $filename = filecleanup($filename);
1765
61717661 1766 my $meta = $updater->getmeta($filename,$stickyInfo);
3486595b 1767 unless (defined $meta->{revision}) {
ab07681f 1768 $meta->{revision} = "1.1";
3486595b 1769 }
3fda8c4c 1770
7d90095a 1771 my ( $filepart, $dirpart ) = filenamesplit($filename, 1);
3fda8c4c
ML
1772
1773 $log->debug("Checked-in $dirpart : $filename");
1774
392e2817 1775 print "M $state->{CVSROOT}/$state->{module}/$filename,v <-- $dirpart$filepart\n";
3486595b 1776 if ( defined $meta->{filehash} && $meta->{filehash} eq "deleted" )
3fda8c4c 1777 {
ab07681f 1778 print "M new revision: delete; previous revision: $oldmeta{$filename}{revision}\n";
3fda8c4c
ML
1779 print "Remove-entry $dirpart\n";
1780 print "$filename\n";
1781 } else {
ab07681f 1782 if ($meta->{revision} eq "1.1") {
459bad77
FL
1783 print "M initial revision: 1.1\n";
1784 } else {
ab07681f 1785 print "M new revision: $meta->{revision}; previous revision: $oldmeta{$filename}{revision}\n";
459bad77 1786 }
3fda8c4c
ML
1787 print "Checked-in $dirpart\n";
1788 print "$filename\n";
90948a42 1789 my $kopts = kopts_from_path($filename,"sha1",$meta->{filehash});
61717661
MO
1790 print "/$filepart/$meta->{revision}//$kopts/" .
1791 getStickyTagOrDate($stickyInfo) . "\n";
3fda8c4c
ML
1792 }
1793 }
1794
044182ef 1795 cleanupWorkTree();
3fda8c4c
ML
1796 print "ok\n";
1797}
1798
1799sub req_status
1800{
1801 my ( $cmd, $data ) = @_;
1802
1803 argsplit("status");
1804
1805 $log->info("req_status : " . ( defined($data) ? $data : "[NULL]" ));
1806 #$log->debug("status state : " . Dumper($state));
1807
1808 # Grab a handle to the SQLite db and do any necessary updates
4d804c0e
MO
1809 my $updater;
1810 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
3fda8c4c
ML
1811 $updater->update();
1812
4d804c0e
MO
1813 # if no files were specified, we need to work out what files we should
1814 # be providing status on ...
7d90095a 1815 argsfromdir($updater);
3fda8c4c 1816
addf88e4 1817 # foreach file specified on the command line ...
3fda8c4c
ML
1818 foreach my $filename ( @{$state->{args}} )
1819 {
1820 $filename = filecleanup($filename);
1821
4d804c0e
MO
1822 if ( exists($state->{opt}{l}) &&
1823 index($filename, '/', length($state->{prependdir})) >= 0 )
1824 {
1825 next;
1826 }
852b921c 1827
3fda8c4c
ML
1828 my $wrev = revparse($filename);
1829
61717661
MO
1830 my $stickyInfo = resolveStickyInfo($filename);
1831 my $meta = $updater->getmeta($filename,$stickyInfo);
1832 my $oldmeta = $meta;
1833
4d804c0e
MO
1834 # If the working copy is an old revision, lets get that
1835 # version too for comparison.
ab07681f 1836 if ( defined($wrev) and $wrev ne $meta->{revision} )
3fda8c4c 1837 {
61717661
MO
1838 my($rmRev)=$wrev;
1839 $rmRev=~s/^-//;
1840 $oldmeta = $updater->getmeta($filename, $rmRev);
3fda8c4c
ML
1841 }
1842
1843 # TODO : All possible statuses aren't yet implemented
1844 my $status;
4d804c0e
MO
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
ab07681f 1848 $wrev eq $meta->{revision} and
4d804c0e
MO
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
ab07681f 1854 $meta->{filehash} ) ) )
4d804c0e 1855 {
ab07681f 1856 $status = "Up-to-date"
4d804c0e
MO
1857 }
1858
ab07681f
MO
1859 # Need checkout if the working copy has a different (usually
1860 # older) revision than the repo copy, and the working copy is
1861 # unmodified
4d804c0e 1862 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
ab07681f 1863 $meta->{revision} ne $wrev and
4d804c0e
MO
1864 ( $state->{entries}{$filename}{unchanged} or
1865 ( defined($state->{entries}{$filename}{modified_hash}) and
1866 $state->{entries}{$filename}{modified_hash} eq
1867 $oldmeta->{filehash} ) ) )
1868 {
1869 $status ||= "Needs Checkout";
1870 }
1871
1872 # Need checkout if it exists in the repo but doesn't have a working
1873 # copy
1874 if ( not defined ( $wrev ) and defined ( $meta->{revision} ) )
1875 {
1876 $status ||= "Needs Checkout";
1877 }
1878
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
ab07681f 1882 $wrev eq $meta->{revision} and
61717661 1883 $wrev ne "0" and
4d804c0e
MO
1884 $state->{entries}{$filename}{modified_filename} )
1885 {
1886 $status ||= "Locally Modified";
1887 }
1888
ab07681f
MO
1889 # Needs Merge if working copy revision is different
1890 # (usually older) than repo copy and there are local changes
4d804c0e 1891 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
ab07681f 1892 $meta->{revision} ne $wrev and
4d804c0e
MO
1893 $state->{entries}{$filename}{modified_filename} )
1894 {
1895 $status ||= "Needs Merge";
1896 }
1897
1898 if ( defined ( $state->{entries}{$filename}{revision} ) and
61717661
MO
1899 ( !defined($meta->{revision}) ||
1900 $meta->{revision} eq "0" ) )
4d804c0e
MO
1901 {
1902 $status ||= "Locally Added";
1903 }
1904 if ( defined ( $wrev ) and defined ( $meta->{revision} ) and
ab07681f 1905 $wrev eq "-$meta->{revision}" )
4d804c0e
MO
1906 {
1907 $status ||= "Locally Removed";
1908 }
1909 if ( defined ( $state->{entries}{$filename}{conflict} ) and
1910 $state->{entries}{$filename}{conflict} =~ /^\+=/ )
1911 {
1912 $status ||= "Unresolved Conflict";
1913 }
1914 if ( 0 )
1915 {
1916 $status ||= "File had conflicts on merge";
1917 }
3fda8c4c
ML
1918
1919 $status ||= "Unknown";
1920
23b7180f
DD
1921 my ($filepart) = filenamesplit($filename);
1922
4d804c0e 1923 print "M =======" . ( "=" x 60 ) . "\n";
23b7180f 1924 print "M File: $filepart\tStatus: $status\n";
3fda8c4c
ML
1925 if ( defined($state->{entries}{$filename}{revision}) )
1926 {
4d804c0e
MO
1927 print "M Working revision:\t" .
1928 $state->{entries}{$filename}{revision} . "\n";
3fda8c4c
ML
1929 } else {
1930 print "M Working revision:\tNo entry for $filename\n";
1931 }
1932 if ( defined($meta->{revision}) )
1933 {
ab07681f 1934 print "M Repository revision:\t" .
4d804c0e
MO
1935 $meta->{revision} .
1936 "\t$state->{CVSROOT}/$state->{module}/$filename,v\n";
abd66f22
MO
1937 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
1938 my($tag)=($tagOrDate=~m/^T(.+)$/);
1939 if( !defined($tag) )
1940 {
1941 $tag="(none)";
1942 }
1943 print "M Sticky Tag:\t\t$tag\n";
1944 my($date)=($tagOrDate=~m/^D(.+)$/);
1945 if( !defined($date) )
1946 {
1947 $date="(none)";
1948 }
1949 print "M Sticky Date:\t\t$date\n";
1950 my($options)=$state->{entries}{$filename}{options};
1951 if( $options eq "" )
1952 {
1953 $options="(none)";
1954 }
1955 print "M Sticky Options:\t\t$options\n";
3fda8c4c
ML
1956 } else {
1957 print "M Repository revision:\tNo revision control file\n";
1958 }
1959 print "M\n";
1960 }
1961
1962 print "ok\n";
1963}
1964
1965sub req_diff
1966{
1967 my ( $cmd, $data ) = @_;
1968
1969 argsplit("diff");
1970
1971 $log->debug("req_diff : " . ( defined($data) ? $data : "[NULL]" ));
1972 #$log->debug("status state : " . Dumper($state));
1973
1974 my ($revision1, $revision2);
1975 if ( defined ( $state->{opt}{r} ) and ref $state->{opt}{r} eq "ARRAY" )
1976 {
1977 $revision1 = $state->{opt}{r}[0];
1978 $revision2 = $state->{opt}{r}[1];
1979 } else {
1980 $revision1 = $state->{opt}{r};
1981 }
1982
4d804c0e
MO
1983 $log->debug("Diffing revisions " .
1984 ( defined($revision1) ? $revision1 : "[NULL]" ) .
1985 " and " . ( defined($revision2) ? $revision2 : "[NULL]" ) );
3fda8c4c
ML
1986
1987 # Grab a handle to the SQLite db and do any necessary updates
4d804c0e
MO
1988 my $updater;
1989 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
3fda8c4c
ML
1990 $updater->update();
1991
4d804c0e
MO
1992 # if no files were specified, we need to work out what files we should
1993 # be providing status on ...
7d90095a 1994 argsfromdir($updater);
3fda8c4c 1995
61717661
MO
1996 my($foundDiff);
1997
addf88e4 1998 # foreach file specified on the command line ...
61717661 1999 foreach my $argFilename ( @{$state->{args}} )
3fda8c4c 2000 {
61717661 2001 my($filename) = filecleanup($argFilename);
3fda8c4c
ML
2002
2003 my ( $fh, $file1, $file2, $meta1, $meta2, $filediff );
2004
2005 my $wrev = revparse($filename);
2006
61717661
MO
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
3fda8c4c 2013
3fda8c4c
ML
2014 if ( defined ( $revision1 ) )
2015 {
3fda8c4c 2016 $meta1 = $updater->getmeta($filename, $revision1);
61717661
MO
2017 }
2018 elsif( defined($wrev) && $wrev ne "0" )
2019 {
2020 my($rmRev)=$wrev;
2021 $rmRev=~s/^-//;
2022 $meta1 = $updater->getmeta($filename, $rmRev);
2023 }
2024 if ( !defined($meta1) ||
2025 $meta1->{filehash} eq "deleted" )
2026 {
2027 if( !exists($state->{opt}{N}) )
3fda8c4c 2028 {
61717661
MO
2029 if(!defined($revision1))
2030 {
2031 print "E File $filename at revision $revision1 doesn't exist\n";
2032 }
3fda8c4c
ML
2033 next;
2034 }
61717661
MO
2035 elsif( !defined($meta1) )
2036 {
2037 $meta1 = {
2038 name => $filename,
2039 revision => '0',
2040 filehash => 'deleted'
2041 };
2042 }
3fda8c4c
ML
2043 }
2044
61717661
MO
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
2051
3fda8c4c
ML
2052 # if we have a second -r switch, use it too
2053 if ( defined ( $revision2 ) )
2054 {
3fda8c4c 2055 $meta2 = $updater->getmeta($filename, $revision2);
3fda8c4c 2056 }
61717661 2057 elsif(defined($state->{entries}{$filename}{modified_filename}))
3fda8c4c
ML
2058 {
2059 $file2 = $state->{entries}{$filename}{modified_filename};
61717661
MO
2060 $meta2 = {
2061 name => $filename,
2062 revision => '0',
2063 filehash => 'modified'
2064 };
3fda8c4c 2065 }
61717661 2066 elsif( defined($wrev) && ($wrev!~/^-/) )
3fda8c4c 2067 {
61717661
MO
2068 if(!defined($revision1)) # no revision and no modifications:
2069 {
2070 next;
2071 }
3fda8c4c 2072 $meta2 = $updater->getmeta($filename, $wrev);
61717661
MO
2073 }
2074 if(!defined($file2))
2075 {
2076 if ( !defined($meta2) ||
2077 $meta2->{filehash} eq "deleted" )
2078 {
2079 if( !exists($state->{opt}{N}) )
2080 {
2081 if(!defined($revision2))
2082 {
2083 print "E File $filename at revision $revision2 doesn't exist\n";
2084 }
2085 next;
2086 }
2087 elsif( !defined($meta2) )
2088 {
2089 $meta2 = {
2090 name => $filename,
2091 revision => '0',
2092 filehash => 'deleted'
2093 };
2094 }
2095 }
3fda8c4c
ML
2096 }
2097
61717661 2098 if( $meta1->{filehash} eq $meta2->{filehash} )
4d804c0e 2099 {
61717661 2100 $log->info("unchanged $filename");
4d804c0e
MO
2101 next;
2102 }
3fda8c4c 2103
61717661
MO
2104 # Retrieve revision contents:
2105 ( undef, $file1 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2106 transmitfile($meta1->{filehash}, { targetfile => $file1 });
2107
2108 if(!defined($file2))
4d804c0e 2109 {
61717661
MO
2110 ( undef, $file2 ) = tempfile( DIR => $TEMP_DIR, OPEN => 0 );
2111 transmitfile($meta2->{filehash}, { targetfile => $file2 });
4d804c0e 2112 }
3fda8c4c 2113
61717661
MO
2114 # Generate the actual diff:
2115 print "M Index: $argFilename\n";
4d804c0e 2116 print "M =======" . ( "=" x 60 ) . "\n";
3fda8c4c 2117 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
61717661 2118 if ( defined ( $meta1 ) && $meta1->{revision} ne "0" )
4d804c0e 2119 {
ab07681f 2120 print "M retrieving revision $meta1->{revision}\n"
4d804c0e 2121 }
61717661 2122 if ( defined ( $meta2 ) && $meta2->{revision} ne "0" )
4d804c0e 2123 {
ab07681f 2124 print "M retrieving revision $meta2->{revision}\n"
4d804c0e 2125 }
3fda8c4c 2126 print "M diff ";
9462953a 2127 foreach my $opt ( sort keys %{$state->{opt}} )
3fda8c4c
ML
2128 {
2129 if ( ref $state->{opt}{$opt} eq "ARRAY" )
2130 {
2131 foreach my $value ( @{$state->{opt}{$opt}} )
2132 {
2133 print "-$opt $value ";
2134 }
2135 } else {
2136 print "-$opt ";
4d804c0e
MO
2137 if ( defined ( $state->{opt}{$opt} ) )
2138 {
2139 print "$state->{opt}{$opt} "
2140 }
3fda8c4c
ML
2141 }
2142 }
61717661 2143 print "$argFilename\n";
3fda8c4c 2144
4d804c0e
MO
2145 $log->info("Diffing $filename -r $meta1->{revision} -r " .
2146 ( $meta2->{revision} or "workingcopy" ));
3fda8c4c 2147
61717661
MO
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.)
3fda8c4c 2159
61717661
MO
2160 my (@diffCmd) = ( 'diff' );
2161 if ( exists($state->{opt}{N}) )
3fda8c4c 2162 {
61717661 2163 push @diffCmd,"-N";
3fda8c4c 2164 }
61717661
MO
2165 if ( exists $state->{opt}{u} )
2166 {
2167 push @diffCmd,("-u","-L");
2168 if( $meta1->{filehash} eq "deleted" )
2169 {
2170 push @diffCmd,"/dev/null";
2171 } else {
2172 push @diffCmd,("$argFilename\trevision $meta1->{revision}");
2173 }
3fda8c4c 2174
61717661
MO
2175 if( defined($meta2->{filehash}) )
2176 {
2177 if( $meta2->{filehash} eq "deleted" )
2178 {
2179 push @diffCmd,("-L","/dev/null");
2180 } else {
2181 push @diffCmd,("-L",
2182 "$argFilename\trevision $meta2->{revision}");
2183 }
2184 } else {
2185 push @diffCmd,("-L","$argFilename\tworking copy");
2186 }
2187 }
2188 push @diffCmd,($file1,$file2);
2189 if(!open(DIFF,"-|",@diffCmd))
3fda8c4c 2190 {
61717661 2191 $log->warn("Unable to run diff: $!");
3fda8c4c 2192 }
61717661
MO
2193 my($diffLine);
2194 while(defined($diffLine=<DIFF>))
2195 {
2196 print "M $diffLine";
2197 $foundDiff=1;
2198 }
2199 close(DIFF);
3fda8c4c
ML
2200 }
2201
61717661
MO
2202 if($foundDiff)
2203 {
2204 print "error \n";
2205 }
2206 else
2207 {
2208 print "ok\n";
2209 }
3fda8c4c
ML
2210}
2211
2212sub req_log
2213{
2214 my ( $cmd, $data ) = @_;
2215
2216 argsplit("log");
2217
2218 $log->debug("req_log : " . ( defined($data) ? $data : "[NULL]" ));
2219 #$log->debug("log state : " . Dumper($state));
2220
ab07681f
MO
2221 my ( $revFilter );
2222 if ( defined ( $state->{opt}{r} ) )
2223 {
2224 $revFilter = $state->{opt}{r};
3fda8c4c
ML
2225 }
2226
2227 # Grab a handle to the SQLite db and do any necessary updates
4d804c0e
MO
2228 my $updater;
2229 $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
3fda8c4c
ML
2230 $updater->update();
2231
4d804c0e
MO
2232 # if no files were specified, we need to work out what files we
2233 # should be providing status on ...
7d90095a 2234 argsfromdir($updater);
3fda8c4c 2235
addf88e4 2236 # foreach file specified on the command line ...
3fda8c4c
ML
2237 foreach my $filename ( @{$state->{args}} )
2238 {
2239 $filename = filecleanup($filename);
2240
2241 my $headmeta = $updater->getmeta($filename);
2242
ab07681f
MO
2243 my ($revisions,$totalrevisions) = $updater->getlog($filename,
2244 $revFilter);
3fda8c4c
ML
2245
2246 next unless ( scalar(@$revisions) );
2247
2248 print "M \n";
2249 print "M RCS file: $state->{CVSROOT}/$state->{module}/$filename,v\n";
2250 print "M Working file: $filename\n";
ab07681f 2251 print "M head: $headmeta->{revision}\n";
3fda8c4c
ML
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";
4d804c0e
MO
2257 print "M total revisions: $totalrevisions;\tselected revisions: " .
2258 scalar(@$revisions) . "\n";
3fda8c4c
ML
2259 print "M description:\n";
2260
2261 foreach my $revision ( @$revisions )
2262 {
2263 print "M ----------------------------\n";
ab07681f 2264 print "M revision $revision->{revision}\n";
3fda8c4c 2265 # reformat the date for log output
4d804c0e
MO
2266 if ( $revision->{modified} =~ /(\d+)\s+(\w+)\s+(\d+)\s+(\S+)/ and
2267 defined($DATE_LIST->{$2}) )
2268 {
2269 $revision->{modified} = sprintf('%04d/%02d/%02d %s',
2270 $3, $DATE_LIST->{$2}, $1, $4 );
2271 }
c1bc3061 2272 $revision->{author} = cvs_author($revision->{author});
4d804c0e
MO
2273 print "M date: $revision->{modified};" .
2274 " author: $revision->{author}; state: " .
2275 ( $revision->{filehash} eq "deleted" ? "dead" : "Exp" ) .
2276 "; lines: +2 -3\n";
2277 my $commitmessage;
2278 $commitmessage = $updater->commitmessage($revision->{commithash});
3fda8c4c
ML
2279 $commitmessage =~ s/^/M /mg;
2280 print $commitmessage . "\n";
2281 }
4d804c0e 2282 print "M =======" . ( "=" x 70 ) . "\n";
3fda8c4c
ML
2283 }
2284
2285 print "ok\n";
2286}
2287
2288sub req_annotate
2289{
2290 my ( $cmd, $data ) = @_;
2291
2292 argsplit("annotate");
2293
2294 $log->info("req_annotate : " . ( defined($data) ? $data : "[NULL]" ));
2295 #$log->debug("status state : " . Dumper($state));
2296
2297 # Grab a handle to the SQLite db and do any necessary updates
2298 my $updater = GITCVS::updater->new($state->{CVSROOT}, $state->{module}, $log);
2299 $updater->update();
2300
2301 # if no files were specified, we need to work out what files we should be providing annotate on ...
7d90095a 2302 argsfromdir($updater);
3fda8c4c
ML
2303
2304 # we'll need a temporary checkout dir
044182ef 2305 setupWorkTree();
3fda8c4c 2306
044182ef 2307 $log->info("Temp checkoutdir creation successful, basing annotate session work on '$work->{workDir}', index file is '$ENV{GIT_INDEX_FILE}'");
3fda8c4c 2308
addf88e4 2309 # foreach file specified on the command line ...
3fda8c4c
ML
2310 foreach my $filename ( @{$state->{args}} )
2311 {
2312 $filename = filecleanup($filename);
2313
2314 my $meta = $updater->getmeta($filename);
2315
2316 next unless ( $meta->{revision} );
2317
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];
2322
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)
d2feb01a 2328 system("git", "read-tree", $lastseenin);
3fda8c4c
ML
2329 unless ($? == 0)
2330 {
044182ef 2331 print "E error running git-read-tree $lastseenin $ENV{GIT_INDEX_FILE} $!\n";
a5e40798 2332 return;
3fda8c4c 2333 }
044182ef 2334 $log->info("Created index '$ENV{GIT_INDEX_FILE}' with commit $lastseenin - exit status $?");
3fda8c4c
ML
2335
2336 # do a checkout of the file
d2feb01a 2337 system('git', 'checkout-index', '-f', '-u', $filename);
3fda8c4c 2338 unless ($? == 0) {
a5e40798
JM
2339 print "E error running git-checkout-index -f -u $filename : $!\n";
2340 return;
3fda8c4c
ML
2341 }
2342
2343 $log->info("Annotate $filename");
2344
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
2348 # from the client.
2349
044182ef 2350 my $a_hints = "$work->{workDir}/.annotate_hints";
a5e40798
JM
2351 if (!open(ANNOTATEHINTS, '>', $a_hints)) {
2352 print "E failed to open '$a_hints' for writing: $!\n";
2353 return;
2354 }
3fda8c4c
ML
2355 for (my $i=0; $i < @$revisions; $i++)
2356 {
2357 print ANNOTATEHINTS $revisions->[$i][2];
2358 if ($i+1 < @$revisions) { # have we got a parent?
2359 print ANNOTATEHINTS ' ' . $revisions->[$i+1][2];
2360 }
2361 print ANNOTATEHINTS "\n";
2362 }
2363
2364 print ANNOTATEHINTS "\n";
a5e40798
JM
2365 close ANNOTATEHINTS
2366 or (print "E failed to write $a_hints: $!\n"), return;
3fda8c4c 2367
d2feb01a 2368 my @cmd = (qw(git annotate -l -S), $a_hints, $filename);
a5e40798
JM
2369 if (!open(ANNOTATE, "-|", @cmd)) {
2370 print "E error invoking ". join(' ',@cmd) .": $!\n";
2371 return;
2372 }
3fda8c4c
ML
2373 my $metadata = {};
2374 print "E Annotations for $filename\n";
2375 print "E ***************\n";
2376 while ( <ANNOTATE> )
2377 {
2378 if (m/^([a-zA-Z0-9]{40})\t\([^\)]*\)(.*)$/i)
2379 {
2380 my $commithash = $1;
2381 my $data = $2;
2382 unless ( defined ( $metadata->{$commithash} ) )
2383 {
2384 $metadata->{$commithash} = $updater->getmeta($filename, $commithash);
c1bc3061 2385 $metadata->{$commithash}{author} = cvs_author($metadata->{$commithash}{author});
3fda8c4c
ML
2386 $metadata->{$commithash}{modified} = sprintf("%02d-%s-%02d", $1, $2, $3) if ( $metadata->{$commithash}{modified} =~ /^(\d+)\s(\w+)\s\d\d(\d\d)/ );
2387 }
ab07681f 2388 printf("M %-7s (%-8s %10s): %s\n",
3fda8c4c
ML
2389 $metadata->{$commithash}{revision},
2390 $metadata->{$commithash}{author},
2391 $metadata->{$commithash}{modified},
2392 $data
2393 );
2394 } else {
2395 $log->warn("Error in annotate output! LINE: $_");
2396 print "E Annotate error \n";
2397 next;
2398 }
2399 }
2400 close ANNOTATE;
2401 }
2402
2403 # done; get out of the tempdir
df4b3abc 2404 cleanupWorkTree();
3fda8c4c
ML
2405
2406 print "ok\n";
2407
2408}
2409
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.
2413sub argsplit
2414{
3fda8c4c
ML
2415 $state->{args} = [];
2416 $state->{files} = [];
2417 $state->{opt} = {};
2418
1e76b702
FL
2419 return unless( defined($state->{arguments}) and ref $state->{arguments} eq "ARRAY" );
2420
2421 my $type = shift;
2422
3fda8c4c
ML
2423 if ( defined($type) )
2424 {
2425 my $opt = {};
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" );
61717661 2429 $opt = { l => 0, R => 0, k => 1, D => 1, D => 1, r => 2, N => 0 } if ( $type eq "diff" );
3fda8c4c
ML
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" );
2434
2435
2436 while ( scalar ( @{$state->{arguments}} ) > 0 )
2437 {
2438 my $arg = shift @{$state->{arguments}};
2439
2440 next if ( $arg eq "--" );
2441 next unless ( $arg =~ /\S/ );
2442
2443 # if the argument looks like a switch
2444 if ( $arg =~ /^-(\w)(.*)/ )
2445 {
2446 # if it's a switch that takes an argument
2447 if ( $opt->{$1} )
2448 {
2449 # If this switch has already been provided
2450 if ( $opt->{$1} > 1 and exists ( $state->{opt}{$1} ) )
2451 {
2452 $state->{opt}{$1} = [ $state->{opt}{$1} ];
2453 if ( length($2) > 0 )
2454 {
2455 push @{$state->{opt}{$1}},$2;
2456 } else {
2457 push @{$state->{opt}{$1}}, shift @{$state->{arguments}};
2458 }
2459 } else {
2460 # if there's extra data in the arg, use that as the argument for the switch
2461 if ( length($2) > 0 )
2462 {
2463 $state->{opt}{$1} = $2;
2464 } else {
2465 $state->{opt}{$1} = shift @{$state->{arguments}};
2466 }
2467 }
2468 } else {
2469 $state->{opt}{$1} = undef;
2470 }
2471 }
2472 else
2473 {
2474 push @{$state->{args}}, $arg;
2475 }
2476 }
2477 }
2478 else
2479 {
2480 my $mode = 0;
2481
2482 foreach my $value ( @{$state->{arguments}} )
2483 {
2484 if ( $value eq "--" )
2485 {
2486 $mode++;
2487 next;
2488 }
2489 push @{$state->{args}}, $value if ( $mode == 0 );
2490 push @{$state->{files}}, $value if ( $mode == 1 );
2491 }
2492 }
2493}
2494
d66e8f8c
MO
2495# Used by argsfromdir
2496sub expandArg
3fda8c4c 2497{
d66e8f8c 2498 my ($updater,$outNameMap,$outDirMap,$path,$isDir) = @_;
3fda8c4c 2499
d66e8f8c 2500 my $fullPath = filecleanup($path);
7d90095a 2501
d66e8f8c
MO
2502 # Is it a directory?
2503 if( defined($state->{dirMap}{$fullPath}) ||
2504 defined($state->{dirMap}{"$fullPath/"}) )
2505 {
2506 # It is a directory in the user's sandbox.
2507 $isDir=1;
7d90095a 2508
d66e8f8c
MO
2509 if(defined($state->{entries}{$fullPath}))
2510 {
2511 $log->fatal("Inconsistent file/dir type");
2512 die "Inconsistent file/dir type";
2513 }
2514 }
2515 elsif(defined($state->{entries}{$fullPath}))
2516 {
2517 # It is a file in the user's sandbox.
2518 $isDir=0;
2519 }
2520 my($revDirMap,$otherRevDirMap);
2521 if(!defined($isDir) || $isDir)
2522 {
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)
2527
2528 # Order of precedence of sticky tags:
2529 # -A [head]
2530 # -r /tag/
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]
2534 # [head]
2535 # Also, -r may appear twice (for diff).
2536 #
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.
2540
2541 if(exists($state->{opt}{A}))
2542 {
2543 $revDirMap=$updater->getRevisionDirMap();
2544 }
2545 elsif( defined($state->{opt}{r}) and
2546 ref $state->{opt}{r} eq "ARRAY" )
2547 {
2548 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r}[0]);
2549 $otherRevDirMap=$updater->getRevisionDirMap($state->{opt}{r}[1]);
2550 }
2551 elsif(defined($state->{opt}{r}))
2552 {
2553 $revDirMap=$updater->getRevisionDirMap($state->{opt}{r});
2554 }
2555 else
2556 {
2557 my($sticky)=getDirStickyInfo($fullPath);
2558 $revDirMap=$updater->getRevisionDirMap($sticky->{tag});
2559 }
0a7a9a12 2560
d66e8f8c
MO
2561 # Is it a directory?
2562 if( defined($revDirMap->{$fullPath}) ||
2563 defined($otherRevDirMap->{$fullPath}) )
2564 {
2565 $isDir=1;
2566 }
0a7a9a12
JS
2567 }
2568
d66e8f8c
MO
2569 # What to do with it?
2570 if(!$isDir)
82000d74 2571 {
d66e8f8c
MO
2572 $outNameMap->{$fullPath}=1;
2573 }
2574 else
2575 {
2576 $outDirMap->{$fullPath}=1;
3fda8c4c 2577
d66e8f8c
MO
2578 if(defined($revDirMap->{$fullPath}))
2579 {
2580 addDirMapFiles($updater,$outNameMap,$outDirMap,
2581 $revDirMap->{$fullPath});
2582 }
2583 if( defined($otherRevDirMap) &&
2584 defined($otherRevDirMap->{$fullPath}) )
82000d74 2585 {
d66e8f8c
MO
2586 addDirMapFiles($updater,$outNameMap,$outDirMap,
2587 $otherRevDirMap->{$fullPath});
82000d74 2588 }
d66e8f8c
MO
2589 }
2590}
82000d74 2591
d66e8f8c
MO
2592# Used by argsfromdir
2593# Add entries from dirMap to outNameMap. Also recurse into entries
2594# that are subdirectories.
2595sub addDirMapFiles
2596{
2597 my($updater,$outNameMap,$outDirMap,$dirMap)=@_;
82000d74 2598
d66e8f8c
MO
2599 my($fullName);
2600 foreach $fullName (keys(%$dirMap))
2601 {
2602 my $cleanName=$fullName;
2603 if(defined($state->{prependdir}))
2604 {
2605 if(!($cleanName=~s/^\Q$state->{prependdir}\E//))
2606 {
2607 $log->fatal("internal error stripping prependdir");
2608 die "internal error stripping prependdir";
2609 }
2610 }
82000d74 2611
d66e8f8c
MO
2612 if($dirMap->{$fullName} eq "F")
2613 {
2614 $outNameMap->{$cleanName}=1;
2615 }
2616 elsif($dirMap->{$fullName} eq "D")
2617 {
2618 if(!$state->{opt}{l})
2619 {
2620 expandArg($updater,$outNameMap,$outDirMap,$cleanName,1);
2621 }
2622 }
2623 else
82000d74 2624 {
d66e8f8c
MO
2625 $log->fatal("internal error in addDirMapFiles");
2626 die "internal error in addDirMapFiles";
82000d74 2627 }
3fda8c4c
ML
2628 }
2629}
2630
d66e8f8c
MO
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
2636# that directory.
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.
2640sub argsfromdir
2641{
2642 my $updater = shift;
2643
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
2655 # # numbering).
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)
2660 #
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
527d4a63 2667 # # the sandbox?
d66e8f8c
MO
2668 # ci # HERE: Similar to remove...
2669 # # Don't try to implement the confusing/weird
2670 # # ci -r bug er.."feature".
2671
2672 if(scalar(@{$state->{args}})==0)
2673 {
2674 $state->{args} = [ "." ];
2675 }
2676 my %allArgs;
2677 my %allDirs;
2678 for my $file (@{$state->{args}})
2679 {
2680 expandArg($updater,\%allArgs,\%allDirs,$file);
2681 }
2682
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}})
2686 {
2687 $allArgs{remove_prependdir($file)} = 1;
2688 }
2689
2690 $state->{dirArgs} = \%allDirs;
2691 $state->{args} = [
2692 sort {
2693 # Sort priority: by directory depth, then actual file name:
2694 my @piecesA=split('/',$a);
2695 my @piecesB=split('/',$b);
2696
2697 my $count=scalar(@piecesA);
2698 my $tmp=scalar(@piecesB);
2699 return $count<=>$tmp if($count!=$tmp);
2700
2701 for($tmp=0;$tmp<$count;$tmp++)
2702 {
2703 if($piecesA[$tmp] ne $piecesB[$tmp])
2704 {
2705 return $piecesA[$tmp] cmp $piecesB[$tmp]
2706 }
2707 }
2708 return 0;
2709 } keys(%allArgs) ];
2710}
eb5dcb2c
MO
2711
2712## look up directory sticky tag, of either fullPath or a parent:
2713sub getDirStickyInfo
2714{
2715 my($fullPath)=@_;
2716
2717 $fullPath=~s%/+$%%;
2718 while($fullPath ne "" && !defined($state->{dirMap}{"$fullPath/"}))
2719 {
2720 $fullPath=~s%/?[^/]*$%%;
2721 }
2722
2723 if( !defined($state->{dirMap}{"$fullPath/"}) &&
2724 ( $fullPath eq "" ||
2725 $fullPath eq "." ) )
2726 {
2727 return $state->{dirMap}{""}{stickyInfo};
2728 }
2729 else
2730 {
2731 return $state->{dirMap}{"$fullPath/"}{stickyInfo};
2732 }
2733}
2734
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.
2738sub resolveStickyInfo
2739{
2740 my($filename,$stickyTag,$stickyDate,$reset) = @_;
2741
2742 # Order of precedence of sticky tags:
2743 # -A [head]
2744 # -r /tag/
2745 # [file entry sticky tag]
2746 # [the tag specified in dir req_Sticky]
2747 # [the tag specified in a parent dir req_Sticky]
2748 # [head]
2749
2750 my $result;
2751 if($reset)
2752 {
2753 # $result=undef;
2754 }
2755 elsif( defined($stickyTag) && $stickyTag ne "" )
2756 # || ( defined($stickyDate) && $stickyDate ne "" ) # TODO
2757 {
2758 $result={ 'tag' => (defined($stickyTag)?$stickyTag:undef) };
2759
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) };
2765 }
2766 elsif( defined($state->{entries}{$filename}) &&
2767 defined($state->{entries}{$filename}{tag_or_date}) &&
2768 $state->{entries}{$filename}{tag_or_date} ne "" )
2769 {
2770 my($tagOrDate)=$state->{entries}{$filename}{tag_or_date};
2771 if($tagOrDate=~/^T([^ ]+)\s*$/)
2772 {
2773 $result = { 'tag' => $1 };
2774 }
2775 elsif($tagOrDate=~/^D([0-9.]+)\s*$/)
2776 {
2777 $result= { 'date' => $1 };
2778 }
2779 else
2780 {
2781 die "Unknown tag_or_date format\n";
2782 }
2783 }
2784 else
2785 {
2786 $result=getDirStickyInfo($filename);
2787 }
2788
2789 return $result;
2790}
2791
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).
2795sub getStickyTagOrDate
2796{
2797 my($stickyInfo)=@_;
2798
2799 my $result;
2800 if(defined($stickyInfo) && defined($stickyInfo->{tag}))
2801 {
2802 $result="T$stickyInfo->{tag}";
2803 }
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").
2807 else
2808 {
2809 $result="";
2810 }
2811
2812 return $result;
2813}
2814
3fda8c4c
ML
2815# This method cleans up the $state variable after a command that uses arguments has run
2816sub statecleanup
2817{
2818 $state->{files} = [];
d66e8f8c 2819 $state->{dirArgs} = {};
3fda8c4c
ML
2820 $state->{args} = [];
2821 $state->{arguments} = [];
2822 $state->{entries} = {};
eb5dcb2c 2823 $state->{dirMap} = {};
3fda8c4c
ML
2824}
2825
ab07681f 2826# Return working directory CVS revision "1.X" out
832c0e5e 2827# of the working directory "entries" state, for the given filename.
ab07681f 2828# This is prefixed with a dash if the file is scheduled for removal
196e48f4 2829# when it is committed.
3fda8c4c
ML
2830sub revparse
2831{
2832 my $filename = shift;
2833
ab07681f 2834 return $state->{entries}{$filename}{revision};
3fda8c4c
ML
2835}
2836
e78f69a3
DD
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
2841# at a time;
2842# - Otherwise, transmit the size of the file, followed by the file
2843# contents.
3fda8c4c
ML
2844sub transmitfile
2845{
2846 my $filehash = shift;
e78f69a3 2847 my $options = shift;
3fda8c4c
ML
2848
2849 if ( defined ( $filehash ) and $filehash eq "deleted" )
2850 {
2851 $log->warn("filehash is 'deleted'");
2852 return;
2853 }
2854
2855 die "Need filehash" unless ( defined ( $filehash ) and $filehash =~ /^[a-zA-Z0-9]{40}$/ );
2856
27dd7387 2857 my $type = safe_pipe_capture('git', 'cat-file', '-t', $filehash);
3fda8c4c
ML
2858 chomp $type;
2859
2860 die ( "Invalid type '$type' (expected 'blob')" ) unless ( defined ( $type ) and $type eq "blob" );
2861
27dd7387 2862 my $size = safe_pipe_capture('git', 'cat-file', '-s', $filehash);
3fda8c4c
ML
2863 chomp $size;
2864
2865 $log->debug("transmitfile($filehash) size=$size, type=$type");
2866
d2feb01a 2867 if ( open my $fh, '-|', "git", "cat-file", "blob", $filehash )
3fda8c4c 2868 {
e78f69a3 2869 if ( defined ( $options->{targetfile} ) )
3fda8c4c 2870 {
e78f69a3 2871 my $targetfile = $options->{targetfile};
3fda8c4c
ML
2872 open NEWFILE, ">", $targetfile or die("Couldn't open '$targetfile' for writing : $!");
2873 print NEWFILE $_ while ( <$fh> );
a5e40798 2874 close NEWFILE or die("Failed to write '$targetfile': $!");
e78f69a3
DD
2875 } elsif ( defined ( $options->{print} ) && $options->{print} ) {
2876 while ( <$fh> ) {
2877 if( /\n\z/ ) {
2878 print 'M ', $_;
2879 } else {
2880 print 'MT text ', $_, "\n";
2881 }
2882 }
3fda8c4c
ML
2883 } else {
2884 print "$size\n";
2885 print while ( <$fh> );
2886 }
a5e40798 2887 close $fh or die ("Couldn't close filehandle for transmitfile(): $!");
3fda8c4c
ML
2888 } else {
2889 die("Couldn't execute git-cat-file");
2890 }
2891}
2892
2893# This method takes a file name, and returns ( $dirpart, $filepart ) which
5348b6e7 2894# refers to the directory portion and the file portion of the filename
3fda8c4c
ML
2895# respectively
2896sub filenamesplit
2897{
2898 my $filename = shift;
7d90095a 2899 my $fixforlocaldir = shift;
3fda8c4c
ML
2900
2901 my ( $filepart, $dirpart ) = ( $filename, "." );
2902 ( $filepart, $dirpart ) = ( $2, $1 ) if ( $filename =~ /(.*)\/(.*)/ );
2903 $dirpart .= "/";
2904
7d90095a
MS
2905 if ( $fixforlocaldir )
2906 {
2907 $dirpart =~ s/^$state->{prependdir}//;
2908 }
2909
3fda8c4c
ML
2910 return ( $filepart, $dirpart );
2911}
2912
1899cbc5 2913# Cleanup various junk in filename (try to canonicalize it), and
41ccfdd9 2914# add prependdir to accommodate running CVS client from a
1899cbc5 2915# subdirectory (so the output is relative to top directory of the project).
3fda8c4c
ML
2916sub filecleanup
2917{
2918 my $filename = shift;
2919
2920 return undef unless(defined($filename));
2921 if ( $filename =~ /^\// )
2922 {
2923 print "E absolute filenames '$filename' not supported by server\n";
2924 return undef;
2925 }
2926
1899cbc5
MO
2927 if($filename eq ".")
2928 {
2929 $filename="";
2930 }
3fda8c4c 2931 $filename =~ s/^\.\///g;
1899cbc5 2932 $filename =~ s%/+%/%g;
82000d74 2933 $filename = $state->{prependdir} . $filename;
1899cbc5 2934 $filename =~ s%/$%%;
3fda8c4c
ML
2935 return $filename;
2936}
2937
832c0e5e 2938# Remove prependdir from the path, so that it is relative to the directory
1899cbc5
MO
2939# the CVS client was started from, rather than the top of the project.
2940# Essentially the inverse of filecleanup().
2941sub remove_prependdir
2942{
2943 my($path) = @_;
2944 if(defined($state->{prependdir}) && $state->{prependdir} ne "")
2945 {
2946 my($pre)=$state->{prependdir};
2947 $pre=~s%/$%%;
2948 if(!($path=~s%^\Q$pre\E/?%%))
2949 {
2950 $log->fatal("internal error missing prependdir");
2951 die("internal error missing prependdir");
2952 }
2953 }
2954 return $path;
2955}
2956
044182ef
MO
2957sub validateGitDir
2958{
2959 if( !defined($state->{CVSROOT}) )
2960 {
2961 print "error 1 CVSROOT not specified\n";
2962 cleanupWorkTree();
2963 exit;
2964 }
2965 if( $ENV{GIT_DIR} ne ($state->{CVSROOT} . '/') )
2966 {
2967 print "error 1 Internally inconsistent CVSROOT\n";
2968 cleanupWorkTree();
2969 exit;
2970 }
2971}
2972
2973# Setup working directory in a work tree with the requested version
2974# loaded in the index.
2975sub setupWorkTree
2976{
2977 my ($ver) = @_;
2978
2979 validateGitDir();
2980
2981 if( ( defined($work->{state}) && $work->{state} != 1 ) ||
2982 defined($work->{tmpDir}) )
2983 {
2984 $log->warn("Bad work tree state management");
2985 print "error 1 Internal setup multiple work trees without cleanup\n";
2986 cleanupWorkTree();
2987 exit;
2988 }
2989
2990 $work->{workDir} = tempdir ( DIR => $TEMP_DIR );
2991
2992 if( !defined($work->{index}) )
2993 {
2994 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
2995 }
2996
2997 chdir $work->{workDir} or
2998 die "Unable to chdir to $work->{workDir}\n";
2999
3000 $log->info("Setting up GIT_WORK_TREE as '.' in '$work->{workDir}', index file is '$work->{index}'");
3001
3002 $ENV{GIT_WORK_TREE} = ".";
3003 $ENV{GIT_INDEX_FILE} = $work->{index};
3004 $work->{state} = 2;
3005
3006 if($ver)
3007 {
3008 system("git","read-tree",$ver);
3009 unless ($? == 0)
3010 {
3011 $log->warn("Error running git-read-tree");
3012 die "Error running git-read-tree $ver in $work->{workDir} $!\n";
3013 }
3014 }
3015 # else # req_annotate reads tree for each file
3016}
3017
3018# Ensure current directory is in some kind of working directory,
3019# with a recent version loaded in the index.
3020sub ensureWorkTree
3021{
3022 if( defined($work->{tmpDir}) )
3023 {
3024 $log->warn("Bad work tree state management [ensureWorkTree()]");
3025 print "error 1 Internal setup multiple dirs without cleanup\n";
3026 cleanupWorkTree();
3027 exit;
3028 }
3029 if( $work->{state} )
3030 {
3031 return;
3032 }
3033
3034 validateGitDir();
3035
3036 if( !defined($work->{emptyDir}) )
3037 {
3038 $work->{emptyDir} = tempdir ( DIR => $TEMP_DIR, OPEN => 0);
3039 }
3040 chdir $work->{emptyDir} or
3041 die "Unable to chdir to $work->{emptyDir}\n";
3042
27dd7387 3043 my $ver = safe_pipe_capture('git', 'show-ref', '-s', "refs/heads/$state->{module}");
044182ef
MO
3044 chomp $ver;
3045 if ($ver !~ /^[0-9a-f]{40}$/)
3046 {
3047 $log->warn("Error from git show-ref -s refs/head$state->{module}");
3048 print "error 1 cannot find the current HEAD of module";
3049 cleanupWorkTree();
3050 exit;
3051 }
3052
3053 if( !defined($work->{index}) )
3054 {
3055 (undef, $work->{index}) = tempfile ( DIR => $TEMP_DIR, OPEN => 0 );
3056 }
3057
3058 $ENV{GIT_WORK_TREE} = ".";
3059 $ENV{GIT_INDEX_FILE} = $work->{index};
3060 $work->{state} = 1;
3061
3062 system("git","read-tree",$ver);
3063 unless ($? == 0)
3064 {
3065 die "Error running git-read-tree $ver $!\n";
3066 }
3067}
3068
3069# Cleanup working directory that is not needed any longer.
3070sub cleanupWorkTree
3071{
3072 if( ! $work->{state} )
3073 {
3074 return;
3075 }
3076
3077 chdir "/" or die "Unable to chdir '/'\n";
3078
3079 if( defined($work->{workDir}) )
3080 {
3081 rmtree( $work->{workDir} );
3082 undef $work->{workDir};
3083 }
3084 undef $work->{state};
3085}
3086
3087# Setup a temporary directory (not a working tree), typically for
3088# merging dirty state as in req_update.
3089sub setupTmpDir
3090{
3091 $work->{tmpDir} = tempdir ( DIR => $TEMP_DIR );
3092 chdir $work->{tmpDir} or die "Unable to chdir $work->{tmpDir}\n";
3093
3094 return $work->{tmpDir};
3095}
3096
3097# Clean up a previously setupTmpDir. Restore previous work tree if
3098# appropriate.
3099sub cleanupTmpDir
3100{
3101 if ( !defined($work->{tmpDir}) )
3102 {
3103 $log->warn("cleanup tmpdir that has not been setup");
3104 die "Cleanup tmpDir that has not been setup\n";
3105 }
3106 if( defined($work->{state}) )
3107 {
3108 if( $work->{state} == 1 )
3109 {
3110 chdir $work->{emptyDir} or
3111 die "Unable to chdir to $work->{emptyDir}\n";
3112 }
3113 elsif( $work->{state} == 2 )
3114 {
3115 chdir $work->{workDir} or
3116 die "Unable to chdir to $work->{emptyDir}\n";
3117 }
3118 else
3119 {
3120 $log->warn("Inconsistent work dir state");
3121 die "Inconsistent work dir state\n";
3122 }
3123 }
3124 else
3125 {
3126 chdir "/" or die "Unable to chdir '/'\n";
3127 }
3128}
3129
8538e876
AP
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.
3133sub kopts_from_path
3134{
90948a42 3135 my ($path, $srcType, $name) = @_;
8538e876 3136
8a06a632
MO
3137 if ( defined ( $cfg->{gitcvs}{usecrlfattr} ) and
3138 $cfg->{gitcvs}{usecrlfattr} =~ /\s*(1|true|yes)\s*$/i )
3139 {
5ec3e670
EB
3140 my ($val) = check_attr( "text", $path );
3141 if ( $val eq "unspecified" )
8a06a632 3142 {
5ec3e670 3143 $val = check_attr( "crlf", $path );
8a06a632 3144 }
5ec3e670 3145 if ( $val eq "unset" )
8a06a632
MO
3146 {
3147 return "-kb"
3148 }
5ec3e670
EB
3149 elsif ( check_attr( "eol", $path ) ne "unspecified" ||
3150 $val eq "set" || $val eq "input" )
3151 {
3152 return "";
3153 }
8a06a632
MO
3154 else
3155 {
3156 $log->info("Unrecognized check_attr crlf $path : $val");
3157 }
3158 }
8538e876 3159
90948a42 3160 if ( defined ( $cfg->{gitcvs}{allbinary} ) )
8538e876 3161 {
90948a42
MO
3162 if( ($cfg->{gitcvs}{allbinary} =~ /^\s*(1|true|yes)\s*$/i) )
3163 {
3164 return "-kb";
3165 }
3166 elsif( ($cfg->{gitcvs}{allbinary} =~ /^\s*guess\s*$/i) )
3167 {
39b6a4bd 3168 if( is_binary($srcType,$name) )
90948a42 3169 {
39b6a4bd
MO
3170 $log->debug("... as binary");
3171 return "-kb";
90948a42
MO
3172 }
3173 else
3174 {
39b6a4bd 3175 $log->debug("... as text");
90948a42
MO
3176 }
3177 }
8538e876 3178 }
90948a42
MO
3179 # Return "" to give no special treatment to any path
3180 return "";
8538e876
AP
3181}
3182
8a06a632
MO
3183sub check_attr
3184{
3185 my ($attr,$path) = @_;
3186 ensureWorkTree();
3187 if ( open my $fh, '-|', "git", "check-attr", $attr, "--", $path )
3188 {
3189 my $val = <$fh>;
3190 close $fh;
3191 $val =~ s/.*: ([^:\r\n]*)\s*$/$1/;
3192 return $val;
3193 }
3194 else
3195 {
3196 return undef;
3197 }
3198}
3199
90948a42
MO
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.
3202sub is_binary
3203{
3204 my ($srcType,$name) = @_;
3205 $log->debug("is_binary($srcType,$name)");
3206
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.
3210 my @counts;
3211 my $i;
3212 for($i=0;$i<256;$i++)
3213 {
3214 $counts[$i]=0;
3215 }
3216
3217 my $fh = open_blob_or_die($srcType,$name);
3218 my $line;
3219 while( defined($line=<$fh>) )
3220 {
3221 # Any '\0' and bare CR are considered binary.
3222 if( $line =~ /\0|(\r[^\n])/ )
3223 {
3224 close($fh);
3225 return 1;
3226 }
3227
3228 # Count up each character in the line:
3229 my $len=length($line);
3230 for($i=0;$i<$len;$i++)
3231 {
3232 $counts[ord(substr($line,$i,1))]++;
3233 }
3234 }
3235 close $fh;
3236
3237 # Don't count CR and LF as either printable/nonprintable
3238 $counts[ord("\n")]=0;
3239 $counts[ord("\r")]=0;
3240
3241 # Categorize individual character count into printable and nonprintable:
3242 my $printable=0;
3243 my $nonprintable=0;
3244 for($i=0;$i<256;$i++)
3245 {
3246 if( $i < 32 &&
3247 $i != ord("\b") &&
3248 $i != ord("\t") &&
3249 $i != 033 && # ESC
3250 $i != 014 ) # FF
3251 {
3252 $nonprintable+=$counts[$i];
3253 }
3254 elsif( $i==127 ) # DEL
3255 {
3256 $nonprintable+=$counts[$i];
3257 }
3258 else
3259 {
3260 $printable+=$counts[$i];
3261 }
3262 }
3263
3264 return ($printable >> 7) < $nonprintable;
3265}
3266
3267# Returns open file handle. Possible invocations:
3268# - open_blob_or_die("file",$filename);
3269# - open_blob_or_die("sha1",$filehash);
3270sub open_blob_or_die
3271{
3272 my ($srcType,$name) = @_;
3273 my ($fh);
3274 if( $srcType eq "file" )
3275 {
3276 if( !open $fh,"<",$name )
3277 {
3278 $log->warn("Unable to open file $name: $!");
3279 die "Unable to open file $name: $!\n";
3280 }
3281 }
39b6a4bd 3282 elsif( $srcType eq "sha1" )
90948a42
MO
3283 {
3284 unless ( defined ( $name ) and $name =~ /^[a-zA-Z0-9]{40}$/ )
3285 {
3286 $log->warn("Need filehash");
3287 die "Need filehash\n";
3288 }
3289
27dd7387 3290 my $type = safe_pipe_capture('git', 'cat-file', '-t', $name);
90948a42
MO
3291 chomp $type;
3292
3293 unless ( defined ( $type ) and $type eq "blob" )
3294 {
3295 $log->warn("Invalid type '$type' for '$name'");
3296 die ( "Invalid type '$type' (expected 'blob')" )
3297 }
3298
27dd7387 3299 my $size = safe_pipe_capture('git', 'cat-file', '-s', $name);
90948a42
MO
3300 chomp $size;
3301
3302 $log->debug("open_blob_or_die($name) size=$size, type=$type");
3303
3304 unless( open $fh, '-|', "git", "cat-file", "blob", $name )
3305 {
3306 $log->warn("Unable to open sha1 $name");
3307 die "Unable to open sha1 $name\n";
3308 }
3309 }
3310 else
3311 {
3312 $log->warn("Unknown type of blob source: $srcType");
3313 die "Unknown type of blob source: $srcType\n";
3314 }
3315 return $fh;
3316}
3317
d500a1ee
FE
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
3322# character set.
c1bc3061
DD
3323sub cvs_author
3324{
3325 my $author_line = shift;
d500a1ee
FE
3326 (my $author) = $author_line =~ /<([^@>]*)/;
3327
3328 $author =~ s/[^-a-zA-Z0-9_.]/_/g;
3329 $author =~ s/^-/_/;
c1bc3061
DD
3330
3331 $author;
3332}
3333
031a027a
ÆAB
3334
3335sub descramble
3336{
3337 # This table is from src/scramble.c in the CVS source
3338 my @SHIFTS = (
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
3355 );
3356 my ($str) = @_;
3357
fce338a5 3358 # This should never happen, the same password format (A) has been
031a027a 3359 # used by CVS since the beginning of time
1f0eb513
ÆAB
3360 {
3361 my $fmt = substr($str, 0, 1);
3362 die "invalid password format `$fmt'" unless $fmt eq 'A';
3363 }
031a027a
ÆAB
3364
3365 my @str = unpack "C*", substr($str, 1);
3366 my $ret = join '', map { chr $SHIFTS[$_] } @str;
3367 return $ret;
3368}
3369
61717661
MO
3370# Test if the (deep) values of two references to a hash are the same.
3371sub refHashEqual
3372{
3373 my($v1,$v2) = @_;
3374
3375 my $out;
3376 if(!defined($v1))
3377 {
3378 if(!defined($v2))
3379 {
3380 $out=1;
3381 }
3382 }
3383 elsif( !defined($v2) ||
3384 scalar(keys(%{$v1})) != scalar(keys(%{$v2})) )
3385 {
3386 # $out=undef;
3387 }
3388 else
3389 {
3390 $out=1;
3391
3392 my $key;
3393 foreach $key (keys(%{$v1}))
3394 {
3395 if( !exists($v2->{$key}) ||
3396 defined($v1->{$key}) ne defined($v2->{$key}) ||
3397 ( defined($v1->{$key}) &&
3398 $v1->{$key} ne $v2->{$key} ) )
3399 {
3400 $out=undef;
3401 last;
3402 }
3403 }
3404 }
3405
3406 return $out;
3407}
3408
fce13af5
JH
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
3411
3412sub safe_pipe_capture {
3413
3414 my @output;
3415
3416 if (my $pid = open my $child, '-|') {
3417 @output = (<$child>);
3418 close $child or die join(' ',@_).": $! $?";
3419 } else {
3420 exec(@_) or die "$! $?"; # exec() can fail the executable can't be found
3421 }
3422 return wantarray ? @output : join('',@output);
3423}
3424
031a027a 3425
3fda8c4c
ML
3426package GITCVS::log;
3427
3428####
3429#### Copyright The Open University UK - 2006.
3430####
3431#### Authors: Martyn Smith <martyn@catalyst.net.nz>
adc3192e 3432#### Martin Langhoff <martin@laptop.org>
3fda8c4c
ML
3433####
3434####
3435
3436use strict;
3437use warnings;
3438
3439=head1 NAME
3440
3441GITCVS::log
3442
3443=head1 DESCRIPTION
3444
3445This module provides very crude logging with a similar interface to
3446Log::Log4perl
3447
3448=head1 METHODS
3449
3450=cut
3451
3452=head2 new
3453
3454Creates a new log object, optionally you can specify a filename here to
5348b6e7 3455indicate the file to log to. If no log file is specified, you can specify one
3fda8c4c
ML
3456later with method setfile, or indicate you no longer want logging with method
3457nofile.
3458
3459Until one of these methods is called, all log calls will buffer messages ready
3460to write out.
3461
3462=cut
3463sub new
3464{
3465 my $class = shift;
3466 my $filename = shift;
3467
3468 my $self = {};
3469
3470 bless $self, $class;
3471
3472 if ( defined ( $filename ) )
3473 {
3474 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3475 }
3476
3477 return $self;
3478}
3479
3480=head2 setfile
3481
3482This methods takes a filename, and attempts to open that file as the log file.
3483If successful, all buffered data is written out to the file, and any further
3484logging is written directly to the file.
3485
3486=cut
3487sub setfile
3488{
3489 my $self = shift;
3490 my $filename = shift;
3491
3492 if ( defined ( $filename ) )
3493 {
3494 open $self->{fh}, ">>", $filename or die("Couldn't open '$filename' for writing : $!");
3495 }
3496
3497 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3498
3499 while ( my $line = shift @{$self->{buffer}} )
3500 {
3501 print {$self->{fh}} $line;
3502 }
3503}
3504
3505=head2 nofile
3506
3507This method indicates no logging is going to be used. It flushes any entries in
3508the internal buffer, and sets a flag to ensure no further data is put there.
3509
3510=cut
3511sub nofile
3512{
3513 my $self = shift;
3514
3515 $self->{nolog} = 1;
3516
3517 return unless ( defined ( $self->{buffer} ) and ref $self->{buffer} eq "ARRAY" );
3518
3519 $self->{buffer} = [];
3520}
3521
3522=head2 _logopen
3523
3524Internal method. Returns true if the log file is open, false otherwise.
3525
3526=cut
3527sub _logopen
3528{
3529 my $self = shift;
3530
3531 return 1 if ( defined ( $self->{fh} ) and ref $self->{fh} eq "GLOB" );
3532 return 0;
3533}
3534
3535=head2 debug info warn fatal
3536
3537These four methods are wrappers to _log. They provide the actual interface for
3538logging data.
3539
3540=cut
3541sub debug { my $self = shift; $self->_log("debug", @_); }
3542sub info { my $self = shift; $self->_log("info" , @_); }
3543sub warn { my $self = shift; $self->_log("warn" , @_); }
3544sub fatal { my $self = shift; $self->_log("fatal", @_); }
3545
3546=head2 _log
3547
3548This is an internal method called by the logging functions. It generates a
3549timestamp and pushes the logged line either to file, or internal buffer.
3550
3551=cut
3552sub _log
3553{
3554 my $self = shift;
3555 my $level = shift;
3556
3557 return if ( $self->{nolog} );
3558
3559 my @time = localtime;
3560 my $timestring = sprintf("%4d-%02d-%02d %02d:%02d:%02d : %-5s",
3561 $time[5] + 1900,
3562 $time[4] + 1,
3563 $time[3],
3564 $time[2],
3565 $time[1],
3566 $time[0],
3567 uc $level,
3568 );
3569
3570 if ( $self->_logopen )
3571 {
3572 print {$self->{fh}} $timestring . " - " . join(" ",@_) . "\n";
3573 } else {
3574 push @{$self->{buffer}}, $timestring . " - " . join(" ",@_) . "\n";
3575 }
3576}
3577
3578=head2 DESTROY
3579
3580This method simply closes the file handle if one is open
3581
3582=cut
3583sub DESTROY
3584{
3585 my $self = shift;
3586
3587 if ( $self->_logopen )
3588 {
3589 close $self->{fh};
3590 }
3591}
3592
3593package GITCVS::updater;
3594
3595####
3596#### Copyright The Open University UK - 2006.
3597####
3598#### Authors: Martyn Smith <martyn@catalyst.net.nz>
adc3192e 3599#### Martin Langhoff <martin@laptop.org>
3fda8c4c
ML
3600####
3601####
3602
3603use strict;
3604use warnings;
3605use DBI;
3606
3607=head1 METHODS
3608
3609=cut
3610
3611=head2 new
3612
3613=cut
3614sub new
3615{
3616 my $class = shift;
3617 my $config = shift;
3618 my $module = shift;
3619 my $log = shift;
3620
3621 die "Need to specify a git repository" unless ( defined($config) and -d $config );
3622 die "Need to specify a module" unless ( defined($module) );
3623
3624 $class = ref($class) || $class;
3625
3626 my $self = {};
3627
3628 bless $self, $class;
3629
6aeeffd1
JE
3630 $self->{valid_tables} = {'revision' => 1,
3631 'revision_ix1' => 1,
3632 'revision_ix2' => 1,
3633 'head' => 1,
3634 'head_ix1' => 1,
3635 'properties' => 1,
3636 'commitmsgs' => 1};
3637
3fda8c4c 3638 $self->{module} = $module;
3fda8c4c
ML
3639 $self->{git_path} = $config . "/";
3640
3641 $self->{log} = $log;
3642
3643 die "Git repo '$self->{git_path}' doesn't exist" unless ( -d $self->{git_path} );
3644
658b57ad
MO
3645 # Stores full sha1's for various branch/tag names, abbreviations, etc:
3646 $self->{commitRefCache} = {};
3647
eb1780d4 3648 $self->{dbdriver} = $cfg->{gitcvs}{$state->{method}}{dbdriver} ||
473937ed 3649 $cfg->{gitcvs}{dbdriver} || "SQLite";
eb1780d4
FL
3650 $self->{dbname} = $cfg->{gitcvs}{$state->{method}}{dbname} ||
3651 $cfg->{gitcvs}{dbname} || "%Ggitcvs.%m.sqlite";
3652 $self->{dbuser} = $cfg->{gitcvs}{$state->{method}}{dbuser} ||
3653 $cfg->{gitcvs}{dbuser} || "";
3654 $self->{dbpass} = $cfg->{gitcvs}{$state->{method}}{dbpass} ||
3655 $cfg->{gitcvs}{dbpass} || "";
6aeeffd1
JE
3656 $self->{dbtablenameprefix} = $cfg->{gitcvs}{$state->{method}}{dbtablenameprefix} ||
3657 $cfg->{gitcvs}{dbtablenameprefix} || "";
eb1780d4
FL
3658 my %mapping = ( m => $module,
3659 a => $state->{method},
3660 u => getlogin || getpwuid($<) || $<,
3661 G => $self->{git_path},
3662 g => mangle_dirname($self->{git_path}),
3663 );
3664 $self->{dbname} =~ s/%([mauGg])/$mapping{$1}/eg;
3665 $self->{dbuser} =~ s/%([mauGg])/$mapping{$1}/eg;
6aeeffd1
JE
3666 $self->{dbtablenameprefix} =~ s/%([mauGg])/$mapping{$1}/eg;
3667 $self->{dbtablenameprefix} = mangle_tablename($self->{dbtablenameprefix});
eb1780d4 3668
473937ed
FL
3669 die "Invalid char ':' in dbdriver" if $self->{dbdriver} =~ /:/;
3670 die "Invalid char ';' in dbname" if $self->{dbname} =~ /;/;
3671 $self->{dbh} = DBI->connect("dbi:$self->{dbdriver}:dbname=$self->{dbname}",
eb1780d4
FL
3672 $self->{dbuser},
3673 $self->{dbpass});
920a449a 3674 die "Error connecting to database\n" unless defined $self->{dbh};
3fda8c4c
ML
3675
3676 $self->{tables} = {};
0cf611a3 3677 foreach my $table ( keys %{$self->{dbh}->table_info(undef,undef,undef,'TABLE')->fetchall_hashref('TABLE_NAME')} )
3fda8c4c 3678 {
3fda8c4c
ML
3679 $self->{tables}{$table} = 1;
3680 }
3681
3682 # Construct the revision table if required
196e48f4
MO
3683 # The revision table stores an entry for each file, each time that file
3684 # changes.
3685 # numberOfRecords = O( numCommits * averageNumChangedFilesPerCommit )
3686 # This is not sufficient to support "-r {commithash}" for any
3687 # files except files that were modified by that commit (also,
3688 # some places in the code ignore/effectively strip out -r in
3689 # some cases, before it gets passed to getmeta()).
3690 # The "filehash" field typically has a git blob hash, but can also
3691 # be set to "dead" to indicate that the given version of the file
3692 # should not exist in the sandbox.
6aeeffd1 3693 unless ( $self->{tables}{$self->tablename("revision")} )
3fda8c4c 3694 {
6aeeffd1
JE
3695 my $tablename = $self->tablename("revision");
3696 my $ix1name = $self->tablename("revision_ix1");
3697 my $ix2name = $self->tablename("revision_ix2");
3fda8c4c 3698 $self->{dbh}->do("
6aeeffd1 3699 CREATE TABLE $tablename (
3fda8c4c
ML
3700 name TEXT NOT NULL,
3701 revision INTEGER NOT NULL,
3702 filehash TEXT NOT NULL,
3703 commithash TEXT NOT NULL,
3704 author TEXT NOT NULL,
3705 modified TEXT NOT NULL,
3706 mode TEXT NOT NULL
3707 )
3708 ");
178e015c 3709 $self->{dbh}->do("
6aeeffd1
JE
3710 CREATE INDEX $ix1name
3711 ON $tablename (name,revision)
178e015c
SP
3712 ");
3713 $self->{dbh}->do("
6aeeffd1
JE
3714 CREATE INDEX $ix2name
3715 ON $tablename (name,commithash)
178e015c 3716 ");
3fda8c4c
ML
3717 }
3718
178e015c 3719 # Construct the head table if required
196e48f4
MO
3720 # The head table (along with the "last_commit" entry in the property
3721 # table) is the persisted working state of the "sub update" subroutine.
3722 # All of it's data is read entirely first, and completely recreated
3723 # last, every time "sub update" runs.
3724 # This is also used by "sub getmeta" when it is asked for the latest
3725 # version of a file (as opposed to some specific version).
3726 # Another way of thinking about it is as a single slice out of
3727 # "revisions", giving just the most recent revision information for
3728 # each file.
6aeeffd1 3729 unless ( $self->{tables}{$self->tablename("head")} )
3fda8c4c 3730 {
6aeeffd1
JE
3731 my $tablename = $self->tablename("head");
3732 my $ix1name = $self->tablename("head_ix1");
3fda8c4c 3733 $self->{dbh}->do("
6aeeffd1 3734 CREATE TABLE $tablename (
3fda8c4c
ML
3735 name TEXT NOT NULL,
3736 revision INTEGER NOT NULL,
3737 filehash TEXT NOT NULL,
3738 commithash TEXT NOT NULL,
3739 author TEXT NOT NULL,
3740 modified TEXT NOT NULL,
3741 mode TEXT NOT NULL
3742 )
3743 ");
178e015c 3744 $self->{dbh}->do("
6aeeffd1
JE
3745 CREATE INDEX $ix1name
3746 ON $tablename (name)
178e015c 3747 ");
3fda8c4c
ML
3748 }
3749
3750 # Construct the properties table if required
196e48f4 3751 # - "last_commit" - Used by "sub update".
6aeeffd1 3752 unless ( $self->{tables}{$self->tablename("properties")} )
3fda8c4c 3753 {
6aeeffd1 3754 my $tablename = $self->tablename("properties");
3fda8c4c 3755 $self->{dbh}->do("
6aeeffd1 3756 CREATE TABLE $tablename (
3fda8c4c
ML
3757 key TEXT NOT NULL PRIMARY KEY,
3758 value TEXT
3759 )
3760 ");
3761 }
3762
3763 # Construct the commitmsgs table if required
196e48f4
MO
3764 # The commitmsgs table is only used for merge commits, since
3765 # "sub update" will only keep one branch of parents. Shortlogs
3766 # for ignored commits (i.e. not on the chosen branch) will be used
3767 # to construct a replacement "collapsed" merge commit message,
3768 # which will be stored in this table. See also "sub commitmessage".
6aeeffd1 3769 unless ( $self->{tables}{$self->tablename("commitmsgs")} )
3fda8c4c 3770 {
6aeeffd1 3771 my $tablename = $self->tablename("commitmsgs");
3fda8c4c 3772 $self->{dbh}->do("
6aeeffd1 3773 CREATE TABLE $tablename (
3fda8c4c
ML
3774 key TEXT NOT NULL PRIMARY KEY,
3775 value TEXT
3776 )
3777 ");
3778 }
3779
3780 return $self;
3781}
3782
6aeeffd1
JE
3783=head2 tablename
3784
3785=cut
3786sub tablename
3787{
3788 my $self = shift;
3789 my $name = shift;
3790
3791 if (exists $self->{valid_tables}{$name}) {
3792 return $self->{dbtablenameprefix} . $name;
3793 } else {
3794 return undef;
3795 }
3796}
3797
3fda8c4c
ML
3798=head2 update
3799
196e48f4
MO
3800Bring the database up to date with the latest changes from
3801the git repository.
3802
3803Internal working state is read out of the "head" table and the
3804"last_commit" property, then it updates "revisions" based on that, and
3805finally it writes the new internal state back to the "head" table
3806so it can be used as a starting point the next time update is called.
3807
3fda8c4c
ML
3808=cut
3809sub update
3810{
3811 my $self = shift;
3812
3813 # first lets get the commit list
3814 $ENV{GIT_DIR} = $self->{git_path};
3815
27dd7387 3816 my $commitsha1 = ::safe_pipe_capture('git', 'rev-parse', $self->{module});
49fb940e
ML
3817 chomp $commitsha1;
3818
27dd7387 3819 my $commitinfo = ::safe_pipe_capture('git', 'cat-file', 'commit', $self->{module});
3fda8c4c
ML
3820 unless ( $commitinfo =~ /tree\s+[a-zA-Z0-9]{40}/ )
3821 {
3822 die("Invalid module '$self->{module}'");
3823 }
3824
3825
3826 my $git_log;
3827 my $lastcommit = $self->_get_prop("last_commit");
3828
49fb940e 3829 if (defined $lastcommit && $lastcommit eq $commitsha1) { # up-to-date
61717661
MO
3830 # invalidate the gethead cache
3831 $self->clearCommitRefCaches();
49fb940e
ML
3832 return 1;
3833 }
3834
3fda8c4c
ML
3835 # Start exclusive lock here...
3836 $self->{dbh}->begin_work() or die "Cannot lock database for BEGIN";
3837
3838 # TODO: log processing is memory bound
3839 # if we can parse into a 2nd file that is in reverse order
3840 # we can probably do something really efficient
a248c961 3841 my @git_log_params = ('--pretty', '--parents', '--topo-order');
3fda8c4c
ML
3842
3843 if (defined $lastcommit) {
3844 push @git_log_params, "$lastcommit..$self->{module}";
3845 } else {
3846 push @git_log_params, $self->{module};
3847 }
a248c961 3848 # git-rev-list is the backend / plumbing version of git-log
2c3af7e7
MO
3849 open(my $gitLogPipe, '-|', 'git', 'rev-list', @git_log_params)
3850 or die "Cannot call git-rev-list: $!";
3851 my @commits=readCommits($gitLogPipe);
3852 close $gitLogPipe;
3fda8c4c
ML
3853
3854 # Now all the commits are in the @commits bucket
3855 # ordered by time DESC. for each commit that needs processing,
3856 # determine whether it's following the last head we've seen or if
3857 # it's on its own branch, grab a file list, and add whatever's changed
3858 # NOTE: $lastcommit refers to the last commit from previous run
3859 # $lastpicked is the last commit we picked in this run
3860 my $lastpicked;
3861 my $head = {};
3862 if (defined $lastcommit) {
3863 $lastpicked = $lastcommit;
3864 }
3865
3866 my $committotal = scalar(@commits);
3867 my $commitcount = 0;
3868
3869 # Load the head table into $head (for cached lookups during the update process)
ab07681f 3870 foreach my $file ( @{$self->gethead(1)} )
3fda8c4c
ML
3871 {
3872 $head->{$file->{name}} = $file;
3873 }
3874
3875 foreach my $commit ( @commits )
3876 {
3877 $self->{log}->debug("GITCVS::updater - Processing commit $commit->{hash} (" . (++$commitcount) . " of $committotal)");
3878 if (defined $lastpicked)
3879 {
3880 if (!in_array($lastpicked, @{$commit->{parents}}))
3881 {
3882 # skip, we'll see this delta
3883 # as part of a merge later
3884 # warn "skipping off-track $commit->{hash}\n";
3885 next;
3886 } elsif (@{$commit->{parents}} > 1) {
3887 # it is a merge commit, for each parent that is
196e48f4
MO
3888 # not $lastpicked (not given a CVS revision number),
3889 # see if we can get a log
3fda8c4c
ML
3890 # from the merge-base to that parent to put it
3891 # in the message as a merge summary.
3892 my @parents = @{$commit->{parents}};
3893 foreach my $parent (@parents) {
3fda8c4c
ML
3894 if ($parent eq $lastpicked) {
3895 next;
3896 }
196e48f4
MO
3897 # git-merge-base can potentially (but rarely) throw
3898 # several candidate merge bases. let's assume
3899 # that the first one is the best one.
e509db99 3900 my $base = eval {
fce13af5 3901 ::safe_pipe_capture('git', 'merge-base',
a5e40798 3902 $lastpicked, $parent);
e509db99
SP
3903 };
3904 # The two branches may not be related at all,
3905 # in which case merge base simply fails to find
3906 # any, but that's Ok.
3907 next if ($@);
3908
3fda8c4c
ML
3909 chomp $base;
3910 if ($base) {
3911 my @merged;
3912 # print "want to log between $base $parent \n";
d2feb01a 3913 open(GITLOG, '-|', 'git', 'log', '--pretty=medium', "$base..$parent")
a5e40798 3914 or die "Cannot call git-log: $!";
3fda8c4c
ML
3915 my $mergedhash;
3916 while (<GITLOG>) {
3917 chomp;
3918 if (!defined $mergedhash) {
3919 if (m/^commit\s+(.+)$/) {
3920 $mergedhash = $1;
3921 } else {
3922 next;
3923 }
3924 } else {
3925 # grab the first line that looks non-rfc822
3926 # aka has content after leading space
3927 if (m/^\s+(\S.*)$/) {
3928 my $title = $1;
3929 $title = substr($title,0,100); # truncate
3930 unshift @merged, "$mergedhash $title";
3931 undef $mergedhash;
3932 }
3933 }
3934 }
3935 close GITLOG;
3936 if (@merged) {
3937 $commit->{mergemsg} = $commit->{message};
3938 $commit->{mergemsg} .= "\nSummary of merged commits:\n\n";
3939 foreach my $summary (@merged) {
3940 $commit->{mergemsg} .= "\t$summary\n";
3941 }
3942 $commit->{mergemsg} .= "\n\n";
3943 # print "Message for $commit->{hash} \n$commit->{mergemsg}";
3944 }
3945 }
3946 }
3947 }
3948 }
3949
3950 # convert the date to CVS-happy format
2c3af7e7 3951 my $cvsDate = convertToCvsDate($commit->{date});
3fda8c4c
ML
3952
3953 if ( defined ( $lastpicked ) )
3954 {
d2feb01a 3955 my $filepipe = open(FILELIST, '-|', 'git', 'diff-tree', '-z', '-r', $lastpicked, $commit->{hash}) or die("Cannot call git-diff-tree : $!");
e02cd638 3956 local ($/) = "\0";
3fda8c4c
ML
3957 while ( <FILELIST> )
3958 {
e02cd638 3959 chomp;
2c3af7e7 3960 unless ( /^:\d{6}\s+([0-7]{6})\s+[a-f0-9]{40}\s+([a-f0-9]{40})\s+(\w)$/o )
3fda8c4c
ML
3961 {
3962 die("Couldn't process git-diff-tree line : $_");
3963 }
e02cd638
JH
3964 my ($mode, $hash, $change) = ($1, $2, $3);
3965 my $name = <FILELIST>;
3966 chomp($name);
3fda8c4c 3967
e02cd638 3968 # $log->debug("File mode=$mode, hash=$hash, change=$change, name=$name");
3fda8c4c 3969
2c3af7e7 3970 my $dbMode = convertToDbMode($mode);
3fda8c4c 3971
e02cd638 3972 if ( $change eq "D" )
3fda8c4c 3973 {
e02cd638
JH
3974 #$log->debug("DELETE $name");
3975 $head->{$name} = {
3976 name => $name,
3977 revision => $head->{$name}{revision} + 1,
3fda8c4c
ML
3978 filehash => "deleted",
3979 commithash => $commit->{hash},
2c3af7e7 3980 modified => $cvsDate,
3fda8c4c 3981 author => $commit->{author},
2c3af7e7 3982 mode => $dbMode,
3fda8c4c 3983 };
2c3af7e7 3984 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c 3985 }
9027efed 3986 elsif ( $change eq "M" || $change eq "T" )
3fda8c4c 3987 {
e02cd638
JH
3988 #$log->debug("MODIFIED $name");
3989 $head->{$name} = {
3990 name => $name,
3991 revision => $head->{$name}{revision} + 1,
3992 filehash => $hash,
3fda8c4c 3993 commithash => $commit->{hash},
2c3af7e7 3994 modified => $cvsDate,
3fda8c4c 3995 author => $commit->{author},
2c3af7e7 3996 mode => $dbMode,
3fda8c4c 3997 };
2c3af7e7 3998 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c 3999 }
e02cd638 4000 elsif ( $change eq "A" )
3fda8c4c 4001 {
e02cd638
JH
4002 #$log->debug("ADDED $name");
4003 $head->{$name} = {
4004 name => $name,
a7da9adb 4005 revision => $head->{$name}{revision} ? $head->{$name}{revision}+1 : 1,
e02cd638 4006 filehash => $hash,
3fda8c4c 4007 commithash => $commit->{hash},
2c3af7e7 4008 modified => $cvsDate,
3fda8c4c 4009 author => $commit->{author},
2c3af7e7 4010 mode => $dbMode,
3fda8c4c 4011 };
2c3af7e7 4012 $self->insert_rev($name, $head->{$name}{revision}, $hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c
ML
4013 }
4014 else
4015 {
e02cd638 4016 $log->warn("UNKNOWN FILE CHANGE mode=$mode, hash=$hash, change=$change, name=$name");
3fda8c4c
ML
4017 die;
4018 }
4019 }
4020 close FILELIST;
4021 } else {
4022 # this is used to detect files removed from the repo
4023 my $seen_files = {};
4024
d2feb01a 4025 my $filepipe = open(FILELIST, '-|', 'git', 'ls-tree', '-z', '-r', $commit->{hash}) or die("Cannot call git-ls-tree : $!");
e02cd638 4026 local $/ = "\0";
3fda8c4c
ML
4027 while ( <FILELIST> )
4028 {
e02cd638
JH
4029 chomp;
4030 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
3fda8c4c
ML
4031 {
4032 die("Couldn't process git-ls-tree line : $_");
4033 }
4034
2c3af7e7 4035 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
3fda8c4c
ML
4036
4037 $seen_files->{$git_filename} = 1;
4038
4039 my ( $oldhash, $oldrevision, $oldmode ) = (
4040 $head->{$git_filename}{filehash},
4041 $head->{$git_filename}{revision},
4042 $head->{$git_filename}{mode}
4043 );
4044
2c3af7e7 4045 my $dbMode = convertToDbMode($mode);
3fda8c4c
ML
4046
4047 # unless the file exists with the same hash, we need to update it ...
2c3af7e7 4048 unless ( defined($oldhash) and $oldhash eq $git_hash and defined($oldmode) and $oldmode eq $dbMode )
3fda8c4c
ML
4049 {
4050 my $newrevision = ( $oldrevision or 0 ) + 1;
4051
4052 $head->{$git_filename} = {
4053 name => $git_filename,
4054 revision => $newrevision,
4055 filehash => $git_hash,
4056 commithash => $commit->{hash},
2c3af7e7 4057 modified => $cvsDate,
3fda8c4c 4058 author => $commit->{author},
2c3af7e7 4059 mode => $dbMode,
3fda8c4c
ML
4060 };
4061
4062
2c3af7e7 4063 $self->insert_rev($git_filename, $newrevision, $git_hash, $commit->{hash}, $cvsDate, $commit->{author}, $dbMode);
3fda8c4c
ML
4064 }
4065 }
4066 close FILELIST;
4067
4068 # Detect deleted files
9462953a 4069 foreach my $file ( sort keys %$head )
3fda8c4c
ML
4070 {
4071 unless ( exists $seen_files->{$file} or $head->{$file}{filehash} eq "deleted" )
4072 {
4073 $head->{$file}{revision}++;
4074 $head->{$file}{filehash} = "deleted";
4075 $head->{$file}{commithash} = $commit->{hash};
2c3af7e7 4076 $head->{$file}{modified} = $cvsDate;
3fda8c4c
ML
4077 $head->{$file}{author} = $commit->{author};
4078
2c3af7e7 4079 $self->insert_rev($file, $head->{$file}{revision}, $head->{$file}{filehash}, $commit->{hash}, $cvsDate, $commit->{author}, $head->{$file}{mode});
3fda8c4c
ML
4080 }
4081 }
4082 # END : "Detect deleted files"
4083 }
4084
4085
4086 if (exists $commit->{mergemsg})
4087 {
96256bba 4088 $self->insert_mergelog($commit->{hash}, $commit->{mergemsg});
3fda8c4c
ML
4089 }
4090
4091 $lastpicked = $commit->{hash};
4092
4093 $self->_set_prop("last_commit", $commit->{hash});
4094 }
4095
96256bba 4096 $self->delete_head();
9462953a 4097 foreach my $file ( sort keys %$head )
3fda8c4c 4098 {
96256bba 4099 $self->insert_head(
3fda8c4c
ML
4100 $file,
4101 $head->{$file}{revision},
4102 $head->{$file}{filehash},
4103 $head->{$file}{commithash},
4104 $head->{$file}{modified},
4105 $head->{$file}{author},
4106 $head->{$file}{mode},
4107 );
4108 }
4109 # invalidate the gethead cache
658b57ad 4110 $self->clearCommitRefCaches();
3fda8c4c
ML
4111
4112
4113 # Ending exclusive lock here
4114 $self->{dbh}->commit() or die "Failed to commit changes to SQLite";
4115}
4116
2c3af7e7
MO
4117sub readCommits
4118{
4119 my $pipeHandle = shift;
4120 my @commits;
4121
4122 my %commit = ();
4123
4124 while ( <$pipeHandle> )
4125 {
4126 chomp;
4127 if (m/^commit\s+(.*)$/) {
4128 # on ^commit lines put the just seen commit in the stack
4129 # and prime things for the next one
4130 if (keys %commit) {
4131 my %copy = %commit;
4132 unshift @commits, \%copy;
4133 %commit = ();
4134 }
4135 my @parents = split(m/\s+/, $1);
4136 $commit{hash} = shift @parents;
4137 $commit{parents} = \@parents;
4138 } elsif (m/^(\w+?):\s+(.*)$/ && !exists($commit{message})) {
4139 # on rfc822-like lines seen before we see any message,
4140 # lowercase the entry and put it in the hash as key-value
4141 $commit{lc($1)} = $2;
4142 } else {
4143 # message lines - skip initial empty line
4144 # and trim whitespace
4145 if (!exists($commit{message}) && m/^\s*$/) {
4146 # define it to mark the end of headers
4147 $commit{message} = '';
4148 next;
4149 }
4150 s/^\s+//; s/\s+$//; # trim ws
4151 $commit{message} .= $_ . "\n";
4152 }
4153 }
4154
4155 unshift @commits, \%commit if ( keys %commit );
4156
4157 return @commits;
4158}
4159
4160sub convertToCvsDate
4161{
4162 my $date = shift;
4163 # Convert from: "git rev-list --pretty" formatted date
4164 # Convert to: "the format specified by RFC822 as modified by RFC1123."
4165 # Example: 26 May 1997 13:01:40 -0400
4166 if( $date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+:\d+:\d+)\s+(\d+)\s+([+-]\d+)$/ )
4167 {
4168 $date = "$2 $1 $4 $3 $5";
4169 }
4170
4171 return $date;
4172}
4173
4174sub convertToDbMode
4175{
4176 my $mode = shift;
4177
4178 # NOTE: The CVS protocol uses a string similar "u=rw,g=rw,o=rw",
4179 # but the database "mode" column historically (and currently)
4180 # only stores the "rw" (for user) part of the string.
4181 # FUTURE: It might make more sense to persist the raw
4182 # octal mode (or perhaps the final full CVS form) instead of
4183 # this half-converted form, but it isn't currently worth the
4184 # backwards compatibility headaches.
4185
1b48d56c 4186 $mode=~/^\d{3}(\d)\d\d$/;
2c3af7e7
MO
4187 my $userBits=$1;
4188
4189 my $dbMode = "";
4190 $dbMode .= "r" if ( $userBits & 4 );
4191 $dbMode .= "w" if ( $userBits & 2 );
4192 $dbMode .= "x" if ( $userBits & 1 );
4193 $dbMode = "rw" if ( $dbMode eq "" );
4194
4195 return $dbMode;
4196}
4197
96256bba
JS
4198sub insert_rev
4199{
4200 my $self = shift;
4201 my $name = shift;
4202 my $revision = shift;
4203 my $filehash = shift;
4204 my $commithash = shift;
4205 my $modified = shift;
4206 my $author = shift;
4207 my $mode = shift;
6aeeffd1 4208 my $tablename = $self->tablename("revision");
96256bba 4209
6aeeffd1 4210 my $insert_rev = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
96256bba
JS
4211 $insert_rev->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4212}
4213
4214sub insert_mergelog
4215{
4216 my $self = shift;
4217 my $key = shift;
4218 my $value = shift;
6aeeffd1 4219 my $tablename = $self->tablename("commitmsgs");
96256bba 4220
6aeeffd1 4221 my $insert_mergelog = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
96256bba
JS
4222 $insert_mergelog->execute($key, $value);
4223}
4224
4225sub delete_head
4226{
4227 my $self = shift;
6aeeffd1 4228 my $tablename = $self->tablename("head");
96256bba 4229
6aeeffd1 4230 my $delete_head = $self->{dbh}->prepare_cached("DELETE FROM $tablename",{},1);
96256bba
JS
4231 $delete_head->execute();
4232}
4233
4234sub insert_head
4235{
4236 my $self = shift;
4237 my $name = shift;
4238 my $revision = shift;
4239 my $filehash = shift;
4240 my $commithash = shift;
4241 my $modified = shift;
4242 my $author = shift;
4243 my $mode = shift;
6aeeffd1 4244 my $tablename = $self->tablename("head");
96256bba 4245
6aeeffd1 4246 my $insert_head = $self->{dbh}->prepare_cached("INSERT INTO $tablename (name, revision, filehash, commithash, modified, author, mode) VALUES (?,?,?,?,?,?,?)",{},1);
96256bba
JS
4247 $insert_head->execute($name, $revision, $filehash, $commithash, $modified, $author, $mode);
4248}
4249
3fda8c4c
ML
4250sub _get_prop
4251{
4252 my $self = shift;
4253 my $key = shift;
6aeeffd1 4254 my $tablename = $self->tablename("properties");
3fda8c4c 4255
6aeeffd1 4256 my $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3fda8c4c
ML
4257 $db_query->execute($key);
4258 my ( $value ) = $db_query->fetchrow_array;
4259
4260 return $value;
4261}
4262
4263sub _set_prop
4264{
4265 my $self = shift;
4266 my $key = shift;
4267 my $value = shift;
6aeeffd1 4268 my $tablename = $self->tablename("properties");
3fda8c4c 4269
6aeeffd1 4270 my $db_query = $self->{dbh}->prepare_cached("UPDATE $tablename SET value=? WHERE key=?",{},1);
3fda8c4c
ML
4271 $db_query->execute($value, $key);
4272
4273 unless ( $db_query->rows )
4274 {
6aeeffd1 4275 $db_query = $self->{dbh}->prepare_cached("INSERT INTO $tablename (key, value) VALUES (?,?)",{},1);
3fda8c4c
ML
4276 $db_query->execute($key, $value);
4277 }
4278
4279 return $value;
4280}
4281
4282=head2 gethead
4283
4284=cut
4285
4286sub gethead
4287{
4288 my $self = shift;
ab07681f 4289 my $intRev = shift;
6aeeffd1 4290 my $tablename = $self->tablename("head");
3fda8c4c
ML
4291
4292 return $self->{gethead_cache} if ( defined ( $self->{gethead_cache} ) );
4293
6aeeffd1 4294 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, mode, revision, modified, commithash, author FROM $tablename ORDER BY name ASC",{},1);
3fda8c4c
ML
4295 $db_query->execute();
4296
4297 my $tree = [];
4298 while ( my $file = $db_query->fetchrow_hashref )
4299 {
ab07681f
MO
4300 if(!$intRev)
4301 {
4302 $file->{revision} = "1.$file->{revision}"
4303 }
3fda8c4c
ML
4304 push @$tree, $file;
4305 }
4306
4307 $self->{gethead_cache} = $tree;
4308
4309 return $tree;
4310}
4311
658b57ad
MO
4312=head2 getAnyHead
4313
4314Returns a reference to an array of getmeta structures, one
4315per file in the specified tree hash.
4316
4317=cut
4318
4319sub getAnyHead
4320{
4321 my ($self,$hash) = @_;
4322
4323 if(!defined($hash))
4324 {
4325 return $self->gethead();
4326 }
4327
4328 my @files;
4329 {
4330 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4331 or die("Cannot call git-ls-tree : $!");
4332 local $/ = "\0";
4333 @files=<$filePipe>;
4334 close $filePipe;
4335 }
4336
4337 my $tree=[];
4338 my($line);
4339 foreach $line (@files)
4340 {
4341 $line=~s/\0$//;
4342 unless ( $line=~/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4343 {
4344 die("Couldn't process git-ls-tree line : $_");
4345 }
4346
4347 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4348 push @$tree, $self->getMetaFromCommithash($git_filename,$hash);
4349 }
4350
4351 return $tree;
4352}
4353
4354=head2 getRevisionDirMap
4355
4356A "revision dir map" contains all the plain-file filenames associated
bb8040f9 4357with a particular revision (tree-ish), organized by directory:
658b57ad
MO
4358
4359 $type = $out->{$dir}{$fullName}
4360
4361The type of each is "F" (for ordinary file) or "D" (for directory,
4362for which the map $out->{$fullName} will also exist).
4363
4364=cut
4365
4366sub getRevisionDirMap
4367{
4368 my ($self,$ver)=@_;
4369
4370 if(!defined($self->{revisionDirMapCache}))
4371 {
4372 $self->{revisionDirMapCache}={};
4373 }
4374
4375 # Get file list (previously cached results are dependent on HEAD,
4376 # but are early in each case):
4377 my $cacheKey;
4378 my (@fileList);
4379 if( !defined($ver) || $ver eq "" )
4380 {
4381 $cacheKey="";
4382 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4383 {
4384 return $self->{revisionDirMapCache}{$cacheKey};
4385 }
4386
4387 my @head = @{$self->gethead()};
4388 foreach my $file ( @head )
4389 {
4390 next if ( $file->{filehash} eq "deleted" );
4391
4392 push @fileList,$file->{name};
4393 }
4394 }
4395 else
4396 {
4397 my ($hash)=$self->lookupCommitRef($ver);
4398 if( !defined($hash) )
4399 {
4400 return undef;
4401 }
4402
4403 $cacheKey=$hash;
4404 if( defined($self->{revisionDirMapCache}{$cacheKey}) )
4405 {
4406 return $self->{revisionDirMapCache}{$cacheKey};
4407 }
4408
4409 open(my $filePipe, '-|', 'git', 'ls-tree', '-z', '-r', $hash)
4410 or die("Cannot call git-ls-tree : $!");
4411 local $/ = "\0";
4412 while ( <$filePipe> )
4413 {
4414 chomp;
4415 unless ( /^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4416 {
4417 die("Couldn't process git-ls-tree line : $_");
4418 }
4419
4420 my($mode, $git_type, $git_hash, $git_filename) = ($1, $2, $3, $4);
4421
4422 push @fileList, $git_filename;
4423 }
4424 close $filePipe;
4425 }
4426
4427 # Convert to normalized form:
4428 my %revMap;
4429 my $file;
4430 foreach $file (@fileList)
4431 {
4432 my($dir) = ($file=~m%^(?:(.*)/)?([^/]*)$%);
4433 $dir='' if(!defined($dir));
4434
4435 # parent directories:
4436 # ... create empty dir maps for parent dirs:
4437 my($td)=$dir;
4438 while(!defined($revMap{$td}))
4439 {
4440 $revMap{$td}={};
4441
4442 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4443 $tp='' if(!defined($tp));
4444 $td=$tp;
4445 }
4446 # ... add children to parent maps (now that they exist):
4447 $td=$dir;
4448 while($td ne "")
4449 {
4450 my($tp)=($td=~m%^(?:(.*)/)?([^/]*)$%);
4451 $tp='' if(!defined($tp));
4452
4453 if(defined($revMap{$tp}{$td}))
4454 {
4455 if($revMap{$tp}{$td} ne 'D')
4456 {
4457 die "Weird file/directory inconsistency in $cacheKey";
4458 }
4459 last; # loop exit
4460 }
4461 $revMap{$tp}{$td}='D';
4462
4463 $td=$tp;
4464 }
4465
4466 # file
4467 $revMap{$dir}{$file}='F';
4468 }
4469
4470 # Save in cache:
4471 $self->{revisionDirMapCache}{$cacheKey}=\%revMap;
4472 return $self->{revisionDirMapCache}{$cacheKey};
4473}
4474
3fda8c4c
ML
4475=head2 getlog
4476
a86c0983
MO
4477See also gethistorydense().
4478
3fda8c4c
ML
4479=cut
4480
4481sub getlog
4482{
4483 my $self = shift;
4484 my $filename = shift;
ab07681f
MO
4485 my $revFilter = shift;
4486
6aeeffd1 4487 my $tablename = $self->tablename("revision");
3fda8c4c 4488
ab07681f
MO
4489 # Filters:
4490 # TODO: date, state, or by specific logins filters?
4491 # TODO: Handle comma-separated list of revFilter items, each item
4492 # can be a range [only case currently handled] or individual
4493 # rev or branch or "branch.".
4494 # TODO: Adjust $db_query WHERE clause based on revFilter, instead of
4495 # manually filtering the results of the query?
4496 my ( $minrev, $maxrev );
4497 if( defined($revFilter) and
4498 $state->{opt}{r} =~ /^(1.(\d+))?(::?)(1.(\d.+))?$/ )
4499 {
4500 my $control = $3;
4501 $minrev = $2;
4502 $maxrev = $5;
4503 $minrev++ if ( defined($minrev) and $control eq "::" );
4504 }
4505
6aeeffd1 4506 my $db_query = $self->{dbh}->prepare_cached("SELECT name, filehash, author, mode, revision, modified, commithash FROM $tablename WHERE name=? ORDER BY revision DESC",{},1);
3fda8c4c
ML
4507 $db_query->execute($filename);
4508
ab07681f 4509 my $totalRevs=0;
3fda8c4c
ML
4510 my $tree = [];
4511 while ( my $file = $db_query->fetchrow_hashref )
4512 {
ab07681f
MO
4513 $totalRevs++;
4514 if( defined($minrev) and $file->{revision} < $minrev )
4515 {
4516 next;
4517 }
4518 if( defined($maxrev) and $file->{revision} > $maxrev )
4519 {
4520 next;
4521 }
4522
4523 $file->{revision} = "1." . $file->{revision};
3fda8c4c
ML
4524 push @$tree, $file;
4525 }
4526
ab07681f 4527 return ($tree,$totalRevs);
3fda8c4c
ML
4528}
4529
4530=head2 getmeta
4531
4532This function takes a filename (with path) argument and returns a hashref of
4533metadata for that file.
4534
bfdafa09
MO
4535There are several ways $revision can be specified:
4536
4537 - A reference to hash that contains a "tag" that is the
4538 actual revision (one of the below). TODO: Also allow it to
4539 specify a "date" in the hash.
4540 - undef, to refer to the latest version on the main branch.
4541 - Full CVS client revision number (mapped to integer in DB, without the
4542 "1." prefix),
4543 - Complex CVS-compatible "special" revision number for
4544 non-linear history (see comment below)
4545 - git commit sha1 hash
4546 - branch or tag name
4547
3fda8c4c
ML
4548=cut
4549
4550sub getmeta
4551{
4552 my $self = shift;
4553 my $filename = shift;
4554 my $revision = shift;
6aeeffd1
JE
4555 my $tablename_rev = $self->tablename("revision");
4556 my $tablename_head = $self->tablename("head");
3fda8c4c 4557
bfdafa09 4558 if ( ref($revision) eq "HASH" )
3fda8c4c 4559 {
bfdafa09 4560 $revision = $revision->{tag};
3fda8c4c 4561 }
bfdafa09
MO
4562
4563 # Overview of CVS revision numbers:
4564 #
4565 # General CVS numbering scheme:
4566 # - Basic mainline branch numbers: "1.1", "1.2", "1.3", etc.
4567 # - Result of "cvs checkin -r" (possible, but not really
4568 # recommended): "2.1", "2.2", etc
4569 # - Branch tag: "1.2.0.n", where "1.2" is revision it was branched
4570 # from, "0" is a magic placeholder that identifies it as a
4571 # branch tag instead of a version tag, and n is 2 times the
4572 # branch number off of "1.2", starting with "2".
4573 # - Version on a branch: "1.2.n.x", where "1.2" is branch-from, "n"
4574 # is branch number off of "1.2" (like n above), and "x" is
4575 # the version number on the branch.
4576 # - Branches can branch off of branches: "1.3.2.7.4.1" (even number
4577 # of components).
4578 # - Odd "n"s are used by "vendor branches" that result
4579 # from "cvs import". Vendor branches have additional
4580 # strangeness in the sense that the main rcs "head" of the main
4581 # branch will (temporarily until first normal commit) point
4582 # to the version on the vendor branch, rather than the actual
4583 # main branch. (FUTURE: This may provide an opportunity
4584 # to use "strange" revision numbers for fast-forward-merged
4585 # branch tip when CVS client is asking for the main branch.)
4586 #
4587 # git-cvsserver CVS-compatible special numbering schemes:
4588 # - Currently git-cvsserver only tries to be identical to CVS for
4589 # simple "1.x" numbers on the "main" branch (as identified
4590 # by the module name that was originally cvs checkout'ed).
4591 # - The database only stores the "x" part, for historical reasons.
4592 # But most of the rest of the cvsserver preserves
4593 # and thinks using the full revision number.
4594 # - To handle non-linear history, it uses a version of the form
4595 # "2.1.1.2000.b.b.b."..., where the 2.1.1.2000 is to help uniquely
4596 # identify this as a special revision number, and there are
4597 # 20 b's that together encode the sha1 git commit from which
4598 # this version of this file originated. Each b is
4599 # the numerical value of the corresponding byte plus
4600 # 100.
4601 # - "plus 100" avoids "0"s, and also reduces the
41ccfdd9 4602 # likelihood of a collision in the case that someone someday
bfdafa09
MO
4603 # writes an import tool that tries to preserve original
4604 # CVS revision numbers, and the original CVS data had done
4605 # lots of branches off of branches and other strangeness to
4606 # end up with a real version number that just happens to look
4607 # like this special revision number form. Also, if needed
4608 # there are several ways to extend/identify alternative encodings
4609 # within the "2.1.1.2000" part if necessary.
4610 # - Unlike real CVS revisions, you can't really reconstruct what
4611 # relation a revision of this form has to other revisions.
4612 # - FUTURE: TODO: Rework database somehow to make up and remember
4613 # fully-CVS-compatible branches and branch version numbers.
4614
4615 my $meta;
4616 if ( defined($revision) )
3fda8c4c 4617 {
bfdafa09
MO
4618 if ( $revision =~ /^1\.(\d+)$/ )
4619 {
4620 my ($intRev) = $1;
4621 my $db_query;
4622 $db_query = $self->{dbh}->prepare_cached(
4623 "SELECT * FROM $tablename_rev WHERE name=? AND revision=?",
4624 {},1);
4625 $db_query->execute($filename, $intRev);
4626 $meta = $db_query->fetchrow_hashref;
4627 }
4628 elsif ( $revision =~ /^2\.1\.1\.2000(\.[1-3][0-9][0-9]){20}$/ )
4629 {
4630 my ($commitHash)=($revision=~/^2\.1\.1\.2000(.*)$/);
4631 $commitHash=~s/\.([0-9]+)/sprintf("%02x",$1-100)/eg;
4632 if($commitHash=~/^[0-9a-f]{40}$/)
4633 {
4634 return $self->getMetaFromCommithash($filename,$commitHash);
4635 }
4636
4637 # error recovery: fall back on head version below
4638 print "E Failed to find $filename version=$revision or commit=$commitHash\n";
4639 $log->warning("failed get $revision with commithash=$commitHash");
4640 undef $revision;
4641 }
4642 elsif ( $revision =~ /^[0-9a-f]{40}$/ )
4643 {
4644 # Try DB first. This is mostly only useful for req_annotate(),
4645 # which only calls this for stuff that should already be in
4646 # the DB. It is fairly likely to be a waste of time
4647 # in most other cases [unless the file happened to be
4648 # modified in $revision specifically], but
4649 # it is probably in the noise compared to how long
4650 # getMetaFromCommithash() will take.
4651 my $db_query;
4652 $db_query = $self->{dbh}->prepare_cached(
4653 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4654 {},1);
4655 $db_query->execute($filename, $revision);
4656 $meta = $db_query->fetchrow_hashref;
4657
4658 if(! $meta)
4659 {
4660 my($revCommit)=$self->lookupCommitRef($revision);
4661 if($revCommit=~/^[0-9a-f]{40}$/)
4662 {
4663 return $self->getMetaFromCommithash($filename,$revCommit);
4664 }
4665
4666 # error recovery: nothing found:
4667 print "E Failed to find $filename version=$revision\n";
4668 $log->warning("failed get $revision");
4669 return $meta;
4670 }
4671 }
4672 else
4673 {
4674 my($revCommit)=$self->lookupCommitRef($revision);
4675 if($revCommit=~/^[0-9a-f]{40}$/)
4676 {
4677 return $self->getMetaFromCommithash($filename,$revCommit);
4678 }
4679
4680 # error recovery: fall back on head version below
4681 print "E Failed to find $filename version=$revision\n";
4682 $log->warning("failed get $revision");
4683 undef $revision; # Allow fallback
4684 }
4685 }
4686
4687 if(!defined($revision))
4688 {
4689 my $db_query;
4690 $db_query = $self->{dbh}->prepare_cached(
4691 "SELECT * FROM $tablename_head WHERE name=?",{},1);
3fda8c4c 4692 $db_query->execute($filename);
bfdafa09 4693 $meta = $db_query->fetchrow_hashref;
3fda8c4c
ML
4694 }
4695
ab07681f
MO
4696 if($meta)
4697 {
4698 $meta->{revision} = "1.$meta->{revision}";
4699 }
4700 return $meta;
3fda8c4c
ML
4701}
4702
658b57ad
MO
4703sub getMetaFromCommithash
4704{
4705 my $self = shift;
4706 my $filename = shift;
4707 my $revCommit = shift;
4708
4709 # NOTE: This function doesn't scale well (lots of forks), especially
4710 # if you have many files that have not been modified for many commits
4711 # (each git-rev-parse redoes a lot of work for each file
4712 # that theoretically could be done in parallel by smarter
4713 # graph traversal).
4714 #
4715 # TODO: Possible optimization strategies:
4716 # - Solve the issue of assigning and remembering "real" CVS
4717 # revision numbers for branches, and ensure the
4718 # data structure can do this efficiently. Perhaps something
4719 # similar to "git notes", and carefully structured to take
4720 # advantage same-sha1-is-same-contents, to roll the same
4721 # unmodified subdirectory data onto multiple commits?
4722 # - Write and use a C tool that is like git-blame, but
4723 # operates on multiple files with file granularity, instead
4724 # of one file with line granularity. Cache
4725 # most-recently-modified in $self->{commitRefCache}{$revCommit}.
4726 # Try to be intelligent about how many files we do with
4727 # one fork (perhaps one directory at a time, without recursion,
4728 # and/or include directory as one line item, recurse from here
4729 # instead of in C tool?).
4730 # - Perhaps we could ask the DB for (filename,fileHash),
4731 # and just guess that it is correct (that the file hadn't
4732 # changed between $revCommit and the found commit, then
4733 # changed back, confusing anything trying to interpret
4734 # history). Probably need to add another index to revisions
4735 # DB table for this.
4736 # - NOTE: Trying to store all (commit,file) keys in DB [to
4737 # find "lastModfiedCommit] (instead of
4738 # just files that changed in each commit as we do now) is
4739 # probably not practical from a disk space perspective.
4740
4741 # Does the file exist in $revCommit?
4742 # TODO: Include file hash in dirmap cache.
4743 my($dirMap)=$self->getRevisionDirMap($revCommit);
4744 my($dir,$file)=($filename=~m%^(?:(.*)/)?([^/]*$)%);
4745 if(!defined($dir))
4746 {
4747 $dir="";
4748 }
4749 if( !defined($dirMap->{$dir}) ||
4750 !defined($dirMap->{$dir}{$filename}) )
4751 {
4752 my($fileHash)="deleted";
4753
4754 my($retVal)={};
4755 $retVal->{name}=$filename;
4756 $retVal->{filehash}=$fileHash;
4757
4758 # not needed and difficult to compute:
4759 $retVal->{revision}="0"; # $revision;
4760 $retVal->{commithash}=$revCommit;
4761 #$retVal->{author}=$commit->{author};
4762 #$retVal->{modified}=convertToCvsDate($commit->{date});
4763 #$retVal->{mode}=convertToDbMode($mode);
4764
4765 return $retVal;
4766 }
4767
fce13af5 4768 my($fileHash) = ::safe_pipe_capture("git","rev-parse","$revCommit:$filename");
658b57ad
MO
4769 chomp $fileHash;
4770 if(!($fileHash=~/^[0-9a-f]{40}$/))
4771 {
4772 die "Invalid fileHash '$fileHash' looking up"
4773 ." '$revCommit:$filename'\n";
4774 }
4775
4776 # information about most recent commit to modify $filename:
4777 open(my $gitLogPipe, '-|', 'git', 'rev-list',
4778 '--max-count=1', '--pretty', '--parents',
4779 $revCommit, '--', $filename)
4780 or die "Cannot call git-rev-list: $!";
4781 my @commits=readCommits($gitLogPipe);
4782 close $gitLogPipe;
4783 if(scalar(@commits)!=1)
4784 {
4785 die "Can't find most recent commit changing $filename\n";
4786 }
4787 my($commit)=$commits[0];
4788 if( !defined($commit) || !defined($commit->{hash}) )
4789 {
4790 return undef;
4791 }
4792
4793 # does this (commit,file) have a real assigned CVS revision number?
4794 my $tablename_rev = $self->tablename("revision");
4795 my $db_query;
4796 $db_query = $self->{dbh}->prepare_cached(
4797 "SELECT * FROM $tablename_rev WHERE name=? AND commithash=?",
4798 {},1);
4799 $db_query->execute($filename, $commit->{hash});
4800 my($meta)=$db_query->fetchrow_hashref;
4801 if($meta)
4802 {
4803 $meta->{revision} = "1.$meta->{revision}";
4804 return $meta;
4805 }
4806
4807 # fall back on special revision number
4808 my($revision)=$commit->{hash};
4809 $revision=~s/(..)/'.' . (hex($1)+100)/eg;
4810 $revision="2.1.1.2000$revision";
4811
4812 # meta data about $filename:
4813 open(my $filePipe, '-|', 'git', 'ls-tree', '-z',
4814 $commit->{hash}, '--', $filename)
4815 or die("Cannot call git-ls-tree : $!");
4816 local $/ = "\0";
4817 my $line;
4818 $line=<$filePipe>;
4819 if(defined(<$filePipe>))
4820 {
4821 die "Expected only a single file for git-ls-tree $filename\n";
4822 }
4823 close $filePipe;
4824
4825 chomp $line;
4826 unless ( $line=~m/^(\d+)\s+(\w+)\s+([a-zA-Z0-9]+)\t(.*)$/o )
4827 {
4828 die("Couldn't process git-ls-tree line : $line\n");
4829 }
4830 my ( $mode, $git_type, $git_hash, $git_filename ) = ( $1, $2, $3, $4 );
4831
4832 # save result:
4833 my($retVal)={};
4834 $retVal->{name}=$filename;
4835 $retVal->{revision}=$revision;
4836 $retVal->{filehash}=$fileHash;
4837 $retVal->{commithash}=$revCommit;
4838 $retVal->{author}=$commit->{author};
4839 $retVal->{modified}=convertToCvsDate($commit->{date});
4840 $retVal->{mode}=convertToDbMode($mode);
4841
4842 return $retVal;
4843}
4844
4845=head2 lookupCommitRef
4846
4847Convert tag/branch/abbreviation/etc into a commit sha1 hash. Caches
4848the result so looking it up again is fast.
4849
4850=cut
4851
4852sub lookupCommitRef
4853{
4854 my $self = shift;
4855 my $ref = shift;
4856
4857 my $commitHash = $self->{commitRefCache}{$ref};
4858 if(defined($commitHash))
4859 {
4860 return $commitHash;
4861 }
4862
fce13af5
JH
4863 $commitHash = ::safe_pipe_capture("git","rev-parse","--verify","--quiet",
4864 $self->unescapeRefName($ref));
658b57ad
MO
4865 $commitHash=~s/\s*$//;
4866 if(!($commitHash=~/^[0-9a-f]{40}$/))
4867 {
4868 $commitHash=undef;
4869 }
4870
4871 if( defined($commitHash) )
4872 {
fce13af5 4873 my $type = ::safe_pipe_capture("git","cat-file","-t",$commitHash);
658b57ad
MO
4874 if( ! ($type=~/^commit\s*$/ ) )
4875 {
4876 $commitHash=undef;
4877 }
4878 }
4879 if(defined($commitHash))
4880 {
4881 $self->{commitRefCache}{$ref}=$commitHash;
4882 }
4883 return $commitHash;
4884}
4885
4886=head2 clearCommitRefCaches
4887
4888Clears cached commit cache (sha1's for various tags/abbeviations/etc),
4889and related caches.
4890
4891=cut
4892
4893sub clearCommitRefCaches
4894{
4895 my $self = shift;
4896 $self->{commitRefCache} = {};
4897 $self->{revisionDirMapCache} = undef;
4898 $self->{gethead_cache} = undef;
4899}
4900
3fda8c4c
ML
4901=head2 commitmessage
4902
4903this function takes a commithash and returns the commit message for that commit
4904
4905=cut
4906sub commitmessage
4907{
4908 my $self = shift;
4909 my $commithash = shift;
6aeeffd1 4910 my $tablename = $self->tablename("commitmsgs");
3fda8c4c
ML
4911
4912 die("Need commithash") unless ( defined($commithash) and $commithash =~ /^[a-zA-Z0-9]{40}$/ );
4913
4914 my $db_query;
6aeeffd1 4915 $db_query = $self->{dbh}->prepare_cached("SELECT value FROM $tablename WHERE key=?",{},1);
3fda8c4c
ML
4916 $db_query->execute($commithash);
4917
4918 my ( $message ) = $db_query->fetchrow_array;
4919
4920 if ( defined ( $message ) )
4921 {
4922 $message .= " " if ( $message =~ /\n$/ );
4923 return $message;
4924 }
4925
fce13af5 4926 my @lines = ::safe_pipe_capture("git", "cat-file", "commit", $commithash);
3fda8c4c
ML
4927 shift @lines while ( $lines[0] =~ /\S/ );
4928 $message = join("",@lines);
4929 $message .= " " if ( $message =~ /\n$/ );
4930 return $message;
4931}
4932
3fda8c4c
ML
4933=head2 gethistorydense
4934
4935This function takes a filename (with path) argument and returns an arrayofarrays
4936containing revision,filehash,commithash ordered by revision descending.
4937
4938This version of gethistory skips deleted entries -- so it is useful for annotate.
4939The 'dense' part is a reference to a '--dense' option available for git-rev-list
4940and other git tools that depend on it.
4941
a86c0983
MO
4942See also getlog().
4943
3fda8c4c
ML
4944=cut
4945sub gethistorydense
4946{
4947 my $self = shift;
4948 my $filename = shift;
6aeeffd1 4949 my $tablename = $self->tablename("revision");
3fda8c4c
ML
4950
4951 my $db_query;
6aeeffd1 4952 $db_query = $self->{dbh}->prepare_cached("SELECT revision, filehash, commithash FROM $tablename WHERE name=? AND filehash!='deleted' ORDER BY revision DESC",{},1);
3fda8c4c
ML
4953 $db_query->execute($filename);
4954
ab07681f
MO
4955 my $result = $db_query->fetchall_arrayref;
4956
4957 my $i;
4958 for($i=0 ; $i<scalar(@$result) ; $i++)
4959 {
4960 $result->[$i][0]="1." . $result->[$i][0];
4961 }
4962
4963 return $result;
3fda8c4c
ML
4964}
4965
51a7e6db
MO
4966=head2 escapeRefName
4967
4968Apply an escape mechanism to compensate for characters that
4969git ref names can have that CVS tags can not.
4970
4971=cut
4972sub escapeRefName
4973{
4974 my($self,$refName)=@_;
4975
4976 # CVS officially only allows [-_A-Za-z0-9] in tag names (or in
4977 # many contexts it can also be a CVS revision number).
4978 #
4979 # Git tags commonly use '/' and '.' as well, but also handle
4980 # anything else just in case:
4981 #
4982 # = "_-s-" For '/'.
4983 # = "_-p-" For '.'.
4984 # = "_-u-" For underscore, in case someone wants a literal "_-" in
4985 # a tag name.
4986 # = "_-xx-" Where "xx" is the hexadecimal representation of the
4987 # desired ASCII character byte. (for anything else)
4988
4989 if(! $refName=~/^[1-9][0-9]*(\.[1-9][0-9]*)*$/)
4990 {
4991 $refName=~s/_-/_-u--/g;
4992 $refName=~s/\./_-p-/g;
4993 $refName=~s%/%_-s-%g;
4994 $refName=~s/[^-_a-zA-Z0-9]/sprintf("_-%02x-",$1)/eg;
4995 }
4996}
4997
4998=head2 unescapeRefName
4999
5000Undo an escape mechanism to compensate for characters that
5001git ref names can have that CVS tags can not.
5002
5003=cut
5004sub unescapeRefName
5005{
5006 my($self,$refName)=@_;
5007
5008 # see escapeRefName() for description of escape mechanism.
5009
5010 $refName=~s/_-([spu]|[0-9a-f][0-9a-f])-/unescapeRefNameChar($1)/eg;
5011
5012 # allowed tag names
5013 # TODO: Perhaps use git check-ref-format, with an in-process cache of
5014 # validated names?
5015 if( !( $refName=~m%^[^-][-a-zA-Z0-9_/.]*$% ) ||
5016 ( $refName=~m%[/.]$% ) ||
5017 ( $refName=~/\.lock$/ ) ||
5018 ( $refName=~m%\.\.|/\.|[[\\:?*~]|\@\{% ) ) # matching }
5019 {
5020 # Error:
5021 $log->warn("illegal refName: $refName");
5022 $refName=undef;
5023 }
5024 return $refName;
5025}
5026
5027sub unescapeRefNameChar
5028{
5029 my($char)=@_;
5030
5031 if($char eq "s")
5032 {
5033 $char="/";
5034 }
5035 elsif($char eq "p")
5036 {
5037 $char=".";
5038 }
5039 elsif($char eq "u")
5040 {
5041 $char="_";
5042 }
5043 elsif($char=~/^[0-9a-f][0-9a-f]$/)
5044 {
5045 $char=chr(hex($char));
5046 }
5047 else
5048 {
5049 # Error case: Maybe it has come straight from user, and
5050 # wasn't supposed to be escaped? Restore it the way we got it:
5051 $char="_-$char-";
5052 }
5053
5054 return $char;
5055}
5056
3fda8c4c
ML
5057=head2 in_array()
5058
5059from Array::PAT - mimics the in_array() function
5060found in PHP. Yuck but works for small arrays.
5061
5062=cut
5063sub in_array
5064{
5065 my ($check, @array) = @_;
5066 my $retval = 0;
5067 foreach my $test (@array){
5068 if($check eq $test){
5069 $retval = 1;
5070 }
5071 }
5072 return $retval;
5073}
5074
eb1780d4
FL
5075=head2 mangle_dirname
5076
5077create a string from a directory name that is suitable to use as
5078part of a filename, mainly by converting all chars except \w.- to _
5079
5080=cut
5081sub mangle_dirname {
5082 my $dirname = shift;
5083 return unless defined $dirname;
5084
5085 $dirname =~ s/[^\w.-]/_/g;
5086
5087 return $dirname;
5088}
3fda8c4c 5089
6aeeffd1
JE
5090=head2 mangle_tablename
5091
5092create a string from a that is suitable to use as part of an SQL table
5093name, mainly by converting all chars except \w to _
5094
5095=cut
5096sub mangle_tablename {
5097 my $tablename = shift;
5098 return unless defined $tablename;
5099
5100 $tablename =~ s/[^\w_]/_/g;
5101
5102 return $tablename;
5103}
5104
3fda8c4c 51051;