1 rizwank 1.1 # Module of TWiki Collaboration Platform, http://TWiki.org/
2 #
3 # Copyright (C) 1999-2003 Peter Thoeny, peter@thoeny.com
4 # Copyright (C) 2002 John Talintyre, john.talintyre@btinternet.com
5 #
6 # For licensing info read license.txt file in the TWiki root.
7 # This program is free software; you can redistribute it and/or
8 # modify it under the terms of the GNU General Public License
9 # as published by the Free Software Foundation; either version 2
10 # of the License, or (at your option) any later version.
11 #
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details, published at
16 # http://www.gnu.org/copyleft/gpl.html
17 #
18 #
19 # Wrapper around the RCS commands required by TWiki
20
21 =begin twiki
22 rizwank 1.1
23 ---+ TWiki::Store::RcsWrap Module
24
25 This module calls rcs
26
27 =cut
28
29 package TWiki::Store::RcsWrap;
30
31 use File::Copy;
32 use TWiki::Store::RcsFile;
33 @ISA = qw(TWiki::Store::RcsFile);
34
35 use strict;
36
37 ## Details of settings
38 #
39 # attachAsciiPath Defines which attachments will be treated as ASCII in RCS
40 # initBinaryCmd RCS init command, needed when initialising a file as binary
41 # ciCmd RCS check in command
42 # coCmd RCS check out command
43 rizwank 1.1 # histCmd RCS history command
44 # infoCmd RCS history on revision command
45 # diffCmd RCS revision diff command
46 # breakLockCmd RCS for breaking a lock
47 # ciDateCmd RCS check in command with date
48 # delRevCmd RCS delete revision command
49 # unlockCmd RCS unlock command
50 # lockCmd RCS lock command
51 # tagCmd RCS tag command
52 #
53 # (from RcsFile)
54 # dataDir
55 # pubDir
56 # attachAsciiPath Defines which attachments will be automatically treated as ASCII in RCS
57 # dirPermission File security for new directories
58
59 # ======================
60 =pod
61
62 ---++ sub new ( $proto, $web, $topic, $attachment, %settings )
63
64 rizwank 1.1 Not yet documented.
65
66 =cut to implementation
67
68 sub new
69 {
70 my( $proto, $web, $topic, $attachment, %settings ) = @_;
71 my $class = ref($proto) || $proto;
72 my $self = TWiki::Store::RcsFile->new( $web, $topic, $attachment, %settings );
73 bless( $self, $class );
74 $self->_settings( %settings );
75 $self->_init();
76 return $self;
77 }
78
79 # ======================
80 =pod
81
82 ---++ sub _settings ( $self, %settings )
83
84 Not yet documented.
85 rizwank 1.1
86 =cut to implementation
87
88 sub _settings
89 {
90 my( $self, %settings ) = @_;
91 $self->{initBinaryCmd} = $settings{initBinaryCmd};
92 $self->{tmpBinaryCmd} = $settings{tmpBinaryCmd};
93 $self->{ciCmd} = $settings{ciCmd};
94 $self->{coCmd} = $settings{coCmd};
95 $self->{histCmd} = $settings{histCmd};
96 $self->{infoCmd} = $settings{infoCmd};
97 $self->{diffCmd} = $settings{diffCmd};
98 $self->{breakLockCmd} = $settings{breakLockCmd};
99 $self->{ciDateCmd} = $settings{ciDateCmd};
100 $self->{delRevCmd} = $settings{delRevCmd};
101 $self->{unlockCmd} = $settings{unlockCmd};
102 $self->{lockCmd} = $settings{lockCmd};
103 $self->{tagCmd} = $settings{tagCmd};
104 }
105
106 rizwank 1.1 #TODO set from TWiki.cfg
107 my $cmdQuote = "'";
108
109 # ======================
110 =pod
111
112 ---++ sub _trace ()
113
114 Not yet documented.
115
116 =cut to implementation
117
118 sub _trace
119 {
120 #my( $text ) = @_;
121 #print $text;
122 }
123
124 # ======================
125 =pod
126
127 rizwank 1.1 ---++ sub _traceExec ()
128
129 Not yet documented.
130
131 =cut to implementation
132
133 sub _traceExec
134 {
135 #my( $cmd, $string, $exit ) = @_;
136 #if( $exit ) {
137 # $exit = " Error: $exit";
138 #} else {
139 # $exit = "";
140 #}
141 #TWiki::writeDebug( "Rcs: $cmd($exit): $string\n" );
142 }
143
144
145 # ======================
146 # Returns false if okay, otherwise an error string
147 =pod
148 rizwank 1.1
149 ---++ sub _binaryChange ( $self )
150
151 Not yet documented.
152
153 =cut to implementation
154
155 sub _binaryChange
156 {
157 my( $self ) = @_;
158 if( $self->getBinary() ) {
159 # Can only do something when changing to binary
160 my $cmd = $self->{"initBinaryCmd"};
161 my $file = $self->file();
162 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote/go;
163 $cmd =~ /(.*)/;
164 $cmd = "$1"; # safe, so untaint variable
165 my $rcsOutput = `$cmd`;
166 my $exit = $? >> 8;
167 _traceExec( $cmd, $rcsOutput, $exit );
168 if( $exit && $rcsOutput ) {
169 rizwank 1.1 $rcsOutput = "$cmd\n$rcsOutput";
170 return $rcsOutput;
171 }
172
173 # Sometimes (on Windows?) rcs file not formed, so check for it
174 if( ! -e $file ) {
175 return "$cmd\nFailed to create history file $file";
176 }
177 }
178 return "";
179 }
180
181 # ======================
182 =pod
183
184 ---++ sub addRevision ( $self, $text, $comment, $userName )
185
186 Not yet documented.
187
188 =cut to implementation
189
190 rizwank 1.1 sub addRevision
191 {
192 my( $self, $text, $comment, $userName ) = @_;
193
194 # Replace file (if exists) with text
195 $self->_save( $self->file(), \$text );
196 return $self->_ci( $self->file(), $comment, $userName );
197 }
198
199 # ======================
200 =pod
201
202 ---++ sub replaceRevision ( $self, $text, $comment, $user, $date )
203
204 Not yet documented.
205 # Replace the top revision
206 # Return non empty string with error message if there is a problem
207 | $date | is on epoch seconds |
208
209 =cut to implementation
210
211 rizwank 1.1 sub replaceRevision
212 {
213 my( $self, $text, $comment, $user, $date ) = @_;
214
215 my $rev = $self->numRevisions();
216 my $file = $self->{file};
217 my $rcsFile = $self->{rcsFile};
218 my $cmd;
219 my $rcsOut;
220
221 # update repository with same userName and date
222 if( $rev == 1 ) {
223 # initial revision, so delete repository file and start again
224 unlink $rcsFile;
225 } else {
226 $self->_deleteRevision( $rev );
227 }
228 $self->_saveFile( $self->file(), $text );
229 $cmd = $self->{ciDateCmd};
230 $date = TWiki::formatTime( $date , "\$rcs", "gmtime");
231 $cmd =~ s/%DATE%/$date/;
232 rizwank 1.1 $cmd =~ s/%USERNAME%/$user/;
233 $file =~ s/$TWiki::securityFilter//go;
234 $rcsFile =~ s/$TWiki::securityFilter//go;
235 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote $cmdQuote$rcsFile$cmdQuote/;
236 $cmd =~ /(.*)/;
237 $cmd = $1; # safe, so untaint variable
238 $rcsOut = `$cmd`;
239 my $exit = $? >> 8;
240 _traceExec( $cmd, $rcsOut, $exit );
241 #$rcsOut =~ s/^Warning\: missing newline.*//os; # forget warning
242 if( $exit ) {
243 $rcsOut = "$cmd\n$rcsOut";
244 return $rcsOut;
245 }
246 return "";
247 }
248
249 # ======================
250 # Return with empty string if only one revision
251 =pod
252
253 rizwank 1.1 ---++ sub deleteRevision ( $self )
254
255 Not yet documented.
256
257 =cut to implementation
258
259 sub deleteRevision
260 {
261 my( $self ) = @_;
262 my $rev = $self->numRevisions();
263 return "" if( $rev == 1 );
264 return $self->_deleteRevision( $rev );
265 }
266
267 # ======================
268 =pod
269
270 ---++ sub _deleteRevision ( $self, $rev )
271
272 Not yet documented.
273
274 rizwank 1.1 =cut to implementation
275
276 sub _deleteRevision
277 {
278 my( $self, $rev ) = @_;
279
280 # delete latest revision (unlock, delete revision, lock)
281 my $file = $self->{file};
282 my $rcsFile = $self->{rcsFile};
283 my $cmd= $self->{unlockCmd};
284 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote $cmdQuote$rcsFile$cmdQuote/go;
285 $cmd =~ /(.*)/;
286 $cmd = $1; # safe, so untaint
287 my $rcsOut = `$cmd`; # capture stderr
288 my $exit = $? >> 8;
289 _traceExec( $cmd, $rcsOut, $exit );
290 #$rcsOut =~ s/^Warning\: missing newline.*//os; # forget warning
291 if( $exit ) {
292 $rcsOut = "$cmd\n$rcsOut";
293 return $rcsOut;
294 }
295 rizwank 1.1 $cmd= $self->{delRevCmd};
296 $cmd =~ s/%REVISION%/1.$rev/go;
297 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote $cmdQuote$rcsFile$cmdQuote/go;
298 $cmd =~ /(.*)/;
299 $cmd = $1; # safe, so untaint variable
300 $rcsOut = `$cmd`;
301 $exit = $? >> 8;
302 _traceExec( $cmd, $rcsOut, $exit );
303 #$rcsOut =~ s/^Warning\: missing newline.*//os; # forget warning
304 if( $exit ) {
305 $rcsOut = "$cmd\n$rcsOut";
306 return $rcsOut;
307 }
308 $cmd= $self->{lockCmd};
309 $cmd =~ s/%REVISION%/$rev/go;
310 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote $cmdQuote$rcsFile$cmdQuote/go;
311 $cmd =~ /(.*)/;
312 $cmd = $1; # safe, so untaint variable
313 $rcsOut = `$cmd`;
314 _traceExec( $cmd, $rcsOut, $exit );
315 #$rcsOut =~ s/^Warning\: missing newline.*//os; # forget warning
316 rizwank 1.1 if( $exit ) {
317 $rcsOut = "$cmd\n$rcsOut";
318 return $rcsOut;
319 }
320 }
321
322 # ======================
323 =pod
324
325 ---++ sub getRevision ( $self, $version )
326
327 Not yet documented.
328
329 =cut to implementation
330
331 sub getRevision
332 {
333 my( $self, $version ) = @_;
334
335 my $tmpfile = "";
336 my $tmpRevFile = "";
337 rizwank 1.1 my $cmd = $self->{"coCmd"};
338 my $file = $self->file();
339 if( $TWiki::OS eq "WINDOWS" ) {
340 # Need to take temporary copy of topic, check it out to file, then read that
341 # Need to put RCS into binary mode to avoid extra \r appearing and
342 # read from binmode file rather than stdout to avoid early file read termination
343 $tmpfile = $self->_mkTmpFilename();
344 $tmpRevFile = "$tmpfile,v";
345 copy( $self->rcsFile(), $tmpRevFile );
346 my $cmd1 = $self->{tmpBinaryCmd};
347 $cmd1 =~ s/%FILENAME%/$cmdQuote$tmpRevFile$cmdQuote/;
348 $cmd1 =~ /(.*)/;
349 $cmd1 = "$1";
350 my $tmp = `$cmd1`;
351 _traceExec( $cmd1, $tmp );
352 $file = $tmpfile;
353 $cmd =~ s/-p%REVISION%/-r%REVISION%/;
354 }
355 $cmd =~ s/%REVISION%/1.$version/;
356 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote/;
357 $cmd =~ /(.*)/;
358 rizwank 1.1 $cmd = "$1"; # untaint
359 my $text = `$cmd`;
360 if( $tmpfile ) {
361 $text = $self->_readFile( $tmpfile );
362 $tmpfile =~ /(.*)/;
363 $tmpfile = "$1"; # untaint
364 unlink $tmpfile;
365 $tmpRevFile =~ /(.*)/;
366 $tmpRevFile = "$1"; # untaint
367 unlink $tmpRevFile;
368 }
369 _traceExec( $cmd, $text );
370 return $text;
371 }
372
373 # ======================
374 =pod
375
376 ---++ sub numRevisions ( $self )
377
378 Not yet documented.
379 rizwank 1.1
380 =cut to implementation
381
382 sub numRevisions
383 {
384 my( $self ) = @_;
385 my $cmd= $self->{"histCmd"};
386 my $rcsFile = $self->rcsFile();
387 if( ! -e $rcsFile ) {
388 return "";
389 }
390
391 $cmd =~ s/%FILENAME%/$cmdQuote$rcsFile$cmdQuote/;
392 $cmd =~ /(.*)/;
393 $cmd = $1; # now safe, so untaint variable
394 my $rcsOutput = `$cmd`;
395 _traceExec( $cmd, $rcsOutput );
396 if( $rcsOutput =~ /head:\s+\d+\.(\d+)\n/ ) {
397 return $1;
398 } else {
399 return ""; # Note this hides possible errors
400 rizwank 1.1 }
401 }
402
403 # ======================
404 =pod
405
406 ---++ sub getRevisionInfo ( $self, $version )
407
408 | FIXME | there is an inconguity here. if you ask for a revisino that does not exist, getRevisionInfo gives you 1.1, but readTopic gives you the last version |
409 Not yet documented.
410 # Date return in epoch seconds
411 # If revision file is missing, information based on actual file is returned.
412
413 =cut to implementation
414
415 sub getRevisionInfo
416 {
417 my( $self, $version ) = @_;
418
419 if( ! $version ) {
420 # PTh 03 Nov 2000: comment out for performance
421 rizwank 1.1 ### $theRev = getRevisionNumber( $theTopic, $theWebName );
422 $version = ""; # do a "rlog -r filename" to get top revision info
423 } else {
424 if ( $version =~ /^\d/ )
425 {
426 #if we are asking for a minor nmber, re-constitue it to Major.minor
427 $version = "1.$version";
428 }
429 }
430
431 my $rcsFile = $self->{rcsFile};
432 my $rcsError = "";
433 my( $dummy, $rev, $date, $user, $comment );
434 if ( -e $rcsFile ) {
435 my $cmd= $self->{infoCmd};
436 $cmd =~ s/%REVISION%/$version/;
437 $cmd =~ s/%FILENAME%/$cmdQuote$rcsFile$cmdQuote/;
438 $cmd =~ /(.*)/; $cmd = $1; # Untaint
439 my $rcsOut = `$cmd`;
440 my $exit = $? >> 8;
441 _traceExec( $cmd, $cmd, $exit );
442 rizwank 1.1 $rcsError = "Error with $cmd, output: $rcsOut" if( $exit );
443 if( ! $rcsError ) {
444 $rcsOut =~ /date: (.*?); author: (.*?);.*\n(.*)\n/;
445 $date = $1 || "";
446 $user = $2 || "";
447 $comment = $3 || "";
448 $date = TWiki::Store::RcsFile::_rcsDateTimeToEpoch( $date );
449 $rcsOut =~ /revision 1.([0-9]*)/;
450 $rev = $1 || "";
451 $rcsError = "Rev missing from revision file $rcsFile" if( ! $rev );
452 }
453 } else {
454 $rcsError = "Revision file $rcsFile is missing";
455 }
456
457 ( $dummy, $rev, $date, $user, $comment ) = $self->_getRevisionInfoDefault() if( $rcsError );
458
459 return( $rcsError, $rev, $date, $user, $comment );
460 }
461
462 # ======================
463 rizwank 1.1 # rev2 newer than rev1
464 =pod
465
466 ---++ sub revisionDiff ( $self, $rev1, $rev2, $contextLines )
467
468 Not yet documented.
469 | Return: =\@diffArray= | reference to an array of [ diffType, $right, $left ] |
470
471 =cut to implementation
472
473 sub revisionDiff
474 {
475 my( $self, $rev1, $rev2, $contextLines ) = @_;
476
477 my $error = "";
478
479 my $tmp= "";
480 if ( $rev1 eq "1" && $rev2 eq "1" ) {
481 my $text = $self->getRevision(1);
482 $tmp = "1a1\n";
483 foreach( split( /\n/, $text ) ) {
484 rizwank 1.1 $tmp = "$tmp> $_\n";
485 }
486 } else {
487 $tmp= $self->{"diffCmd"};
488 $tmp =~ s/%REVISION1%/1.$rev1/;
489 $tmp =~ s/%REVISION2%/1.$rev2/;
490 my $rcsFile = $self->rcsFile();
491 $rcsFile =~ s/$TWiki::securityFilter//go;
492 $tmp =~ s/%FILENAME%/$cmdQuote$rcsFile$cmdQuote/;
493 $tmp =~ s/%CONTEXT%/$contextLines/;
494 $tmp =~ /(.*)/;
495 my $cmd = $1; # now safe, so untaint variable
496 $tmp = `$cmd`;
497 my $exit = $? >> 8;
498 $error = "Error $exit when runing $cmd";
499 _traceExec( $cmd, $tmp, $exit );
500 _trace( "and now $tmp" );
501 # Avoid showing change in revision number!
502 # I'm not too happy with this implementation, I think it may be better to filter before sending to diff command,
503 # possibly using Algorithm::Diff from CPAN.
504 #removed as it causes erronious changes - and it _has_ to be done in Store.pm so it works for rsclite too
505 rizwank 1.1 # $tmp =~ s/[0-9]+c[0-9]+\n[<>]\s*%META:TOPICINFO{[^}]*}%\s*\n---\n[+-<>]\s*%META:TOPICINFO{[^}]*}%\s*n//go;
506 # $tmp =~ s/[+-<>]\s*%META:TOPICINFO{[^}]*}%\s*//go;
507 }
508
509 return ($error, parseRevisionDiff( $tmp ) );
510 }
511
512 # =========================
513 =pod
514
515 ---+++ parseRevisionDiff( $text ) ==> \@diffArray
516
517 | Description: | parse the text into an array of diff cells |
518 | #Description: | unlike Algorithm::Diff I concatinate lines of the same diffType that are sqential (this might be something that should be left up to the renderer) |
519 | Parameter: =$text= | currently unified or rcsdiff format |
520 | Return: =\@diffArray= | reference to an array of [ diffType, $right, $left ] |
521 | TODO: | move into RcsFile and add indirection in Store |
522
523 =cut
524 # -------------------------
525 sub parseRevisionDiff
526 rizwank 1.1 {
527 my( $text ) = @_;
528
529 my ( $diffFormat ) = "normal"; #or rcs, unified...
530 my ( @diffArray );
531
532 $diffFormat = "unified" if ( $text =~ /^---/ );
533
534 $text =~ s/\r//go; # cut CR
535
536 my $lineNumber=1;
537 if ( $diffFormat eq "unified" ) {
538 foreach( split( /\n/, $text ) ) {
539 if ( $lineNumber > 3 ) { #skip the first 2 lines (filenames)
540 if ( /@@ [-+]([0-9]+)([,0-9]+)? [-+]([0-9]+)(,[0-9]+)? @@/ ) {
541 #line number
542 push @diffArray, ["l", $1, $3];
543 } elsif ( /^\-/ ) {
544 s/^\-//go;
545 push @diffArray, ["-", $_, ""];
546 } elsif ( /^\+/ ) {
547 rizwank 1.1 s/^\+//go;
548 push @diffArray, ["+", "", $_];
549 } else {
550 s/^ (.*)$/$1/go;
551 push @diffArray, ["u", $_, $_];
552 }
553 }
554 $lineNumber = $lineNumber + 1;
555 }
556 } else {
557 #"normal" rcsdiff output
558 foreach( split( /\n/, $text ) ) {
559 if ( /^([0-9]+)[0-9\,]*([acd])([0-9]+)/ ) {
560 #line number
561 push @diffArray, ["l", $1, $3];
562 } elsif ( /^</ ) {
563 s/^< //go;
564 push @diffArray, ["-", $_, ""];
565 } elsif ( /^>/ ) {
566 s/^> //go;
567 push @diffArray, ["+", "", $_];
568 rizwank 1.1 } else {
569 #empty lines and the --- selerator in the diff
570 #push @diffArray, ["u", "$_", $_];
571 }
572 }
573 }
574 return \@diffArray;
575 }
576
577 # ======================
578 =pod
579
580 ---++ sub _ci ( $self, $file, $comment, $userName )
581
582 Not yet documented.
583
584 =cut to implementation
585
586 sub _ci
587 {
588 my( $self, $file, $comment, $userName ) = @_;
589 rizwank 1.1
590 # Check that we can write the file being checked in. This won't check that
591 # $file,v is writable, but it _will_ trap 99% of all common errors (permissions
592 # on directory tree)
593 return "$file is not writable" unless ( -w $file );
594
595 my $cmd = $self->{"ciCmd"};
596 my $rcsOutput = "";
597 $cmd =~ s/%USERNAME%/$userName/;
598 $file =~ s/$TWiki::securityFilter//go;
599 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote/;
600 $comment = "none" unless( $comment );
601 $comment =~ s/[\"\'\`\;]//go; # security, Codev.NoShellCharacterEscapingInFileAttachComment, MikeSmith
602 $cmd =~ s/%COMMENT%/$comment/;
603 $cmd =~ /(.*)/;
604 $cmd = $1; # safe, so untaint variable
605 $rcsOutput = `$cmd`; # capture stderr (S.Knutson)
606 my $exit = $? >> 8;
607 _traceExec( $cmd, $rcsOutput );
608 if( $exit && $rcsOutput =~ /no lock set by/ ) {
609 # Try and break lock, setting new one and doing ci again
610 rizwank 1.1 my $cmd = $self->{"breakLockCmd"};
611 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote/go;
612 $cmd =~ /(.*)/;
613 my $out = `$cmd`;
614 _traceExec( $cmd, $out );
615 # Assume it worked, as not sure how to trap failure
616 $rcsOutput = `$cmd`; # capture stderr (S.Knutson)
617 $exit = $? >> 8;
618 _traceExec( $cmd, $rcsOutput );
619 if( ! $exit ) {
620 $rcsOutput = "";
621 }
622 }
623 if( $exit && $rcsOutput ) { # oops, stderr was not empty, return error
624 $rcsOutput = "$cmd\n$rcsOutput";
625 }
626 return $rcsOutput;
627 }
628
629 =pod
630
631 rizwank 1.1 ---+++ setTopicRevisionTag( $web, $topic, $rev, $tag ) ==> $success
632
633 | Description: | sets a names tag on the specified revision |
634 | Parameter: =$web= | webname |
635 | Parameter: =$topic= | topic name |
636 | Parameter: =$rev= | the revision we are taging |
637 | Parameter: =$tag= | the string to tag with |
638 | Return: =$success= | |
639 | TODO: | we _need_ an error mechanism! |
640 | TODO: | NEED to check if the version exists (rcs does not) |
641 | Since: | TWiki:: (20 April 2004) |
642
643 =cut
644
645 sub setTopicRevisionTag
646 {
647 my ( $self, $web, $topic, $rev, $tag ) = @_;
648
649 my $file = $self->{file};
650 if ( -e $file ) {
651 my $cmd= $self->{tagCmd};
652 rizwank 1.1 $cmd =~ s/%REVISION%/$rev/;
653 $cmd =~ s/%FILENAME%/$cmdQuote$file$cmdQuote/;
654 $cmd =~ s/%TAG%/$tag/;
655 $cmd = $cmd." 2>> $TWiki::warningFilename";
656 $cmd =~ /(.*)/; $cmd = $1; # Untaint
657 my $rcsOut = `$cmd`;
658 my $exit = $? >> 8;
659 _traceExec( $cmd, $cmd, $exit );
660 if( $exit && $rcsOut ) { # oops, stderr was not empty, return error
661 $rcsOut = "$cmd\n$$rcsOut";
662 TWiki:writeDebug("RCSWrap::setTopicRevisionTag error - $rcsOut");
663 return;
664 }
665 }
666
667 return 1;#success
668 }
669
670 1;
|