1# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
2#
3# Copyright (C) 2002 John Talintyre, john.talintyre@btinternet.com
4# Copyright (C) 2002-2018 Peter Thoeny, peter[at]thoeny.org
5# and TWiki Contributors. All Rights Reserved. TWiki Contributors
6# are listed in the AUTHORS file in the root of this distribution.
7# NOTE: Please extend that file, not this notice.
8#
9# This program is free software; you can redistribute it and/or
10# modify it under the terms of the GNU General Public License
11# as published by the Free Software Foundation; either version 3
12# of the License, or (at your option) any later version. For
13# more details read LICENSE in the root of this distribution.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
18#
19# As per the GPL, removal of this notice is prohibited.
20
21=pod
22
23---+ package TWiki::Store::RcsWrap
24
25This package does not publish any methods. It implements the
26virtual methods of the [[TWikiStoreRcsFileDotPm][TWiki::Store::RcsFile]] superclass.
27
28Wrapper around the RCS commands required by TWiki.
29There is one of these object for each file stored under RCS.
30
31=cut
32
33package TWiki::Store::RcsWrap;
34use base 'TWiki::Store::RcsFile';
35
36use strict;
37use Assert;
38
39require TWiki::Store;
40require TWiki::Sandbox;
41
42# implements RcsFile
43sub new {
44    return shift->SUPER::new( @_ );
45}
46
47=begin twiki
48
49---++ ObjectMethod finish()
50Break circular references.
51
52=cut
53
54# Note to developers; please undef *all* fields in the object explicitly,
55# whether they are references or not. That way this method is "golden
56# documentation" of the live fields in the object.
57sub finish {
58    my $this = shift;
59    $this->SUPER::finish();
60    undef $this->{binary};
61}
62
63# implements RcsFile
64sub initBinary {
65    my( $this ) = @_;
66
67    $this->{binary} = 1;
68
69    TWiki::Store::RcsFile::mkPathTo( $this->{file} );
70
71    return if -e $this->{rcsFile};
72
73    my ( $rcsOutput, $exit ) =
74      $TWiki::sandbox->sysCommand(
75          $TWiki::cfg{RCS}{initBinaryCmd}, FILENAME => $this->{file} );
76    if( $exit ) {
77        throw Error::Simple( $TWiki::cfg{RCS}{initBinaryCmd}.
78                               ' of '.$this->hidePath($this->{file}).
79                                 ' failed: '.$rcsOutput );
80    } elsif( ! -e $this->{rcsFile} ) {
81        # Sometimes (on Windows?) rcs file not formed, so check for it
82        throw Error::Simple( $TWiki::cfg{RCS}{initBinaryCmd}.
83                               ' of '.$this->hidePath($this->{rcsFile}).
84                                 ' failed to create history file');
85    }
86}
87
88# implements RcsFile
89sub initText {
90    my( $this ) = @_;
91
92    $this->{binary} = 0;
93
94    TWiki::Store::RcsFile::mkPathTo( $this->{file} );
95
96    return if -e $this->{rcsFile};
97
98    my ( $rcsOutput, $exit ) =
99      $TWiki::sandbox->sysCommand
100        ( $TWiki::cfg{RCS}{initTextCmd},
101          FILENAME => $this->{file} );
102    if( $exit ) {
103        $rcsOutput ||= '';
104        throw Error::Simple( $TWiki::cfg{RCS}{initTextCmd}.
105                               ' of '.$this->hidePath($this->{file}).
106                                 ' failed: '.$rcsOutput );
107    } elsif( ! -e $this->{rcsFile} ) {
108        # Sometimes (on Windows?) rcs file not formed, so check for it
109        throw Error::Simple( $TWiki::cfg{RCS}{initTextCmd}.
110                               ' of '.$this->hidePath($this->{rcsFile}).
111                                 ' failed to create history file');
112    }
113}
114
115# implements RcsFile
116sub addRevisionFromText {
117    my( $this, $text, $comment, $user, $date ) = @_;
118    $this->init();
119
120    unless( -e $this->{rcsFile} ) {
121        _lock( $this );
122        _ci( $this, $comment, $user, $date );
123    }
124    TWiki::Store::RcsFile::saveFile( $this, $this->{file}, $text );
125    _lock( $this );
126    _ci( $this, $comment, $user, $date );
127}
128
129# implements RcsFile
130sub addRevisionFromStream {
131    my( $this, $stream, $comment, $user, $date ) = @_;
132    $this->init();
133
134    _lock( $this );
135    TWiki::Store::RcsFile::saveStream( $this, $stream );
136    _ci( $this, $comment, $user, $date );
137}
138
139# implements RcsFile
140sub replaceRevision {
141    my( $this, $text, $comment, $user, $date ) = @_;
142
143    my $rev = $this->numRevisions();
144
145    $comment ||= 'none';
146
147    # update repository with same userName and date
148    if( $rev == 1 ) {
149        # initial revision, so delete repository file and start again
150        unlink $this->{rcsFile};
151    } else {
152        _deleteRevision( $this, $rev );
153    }
154
155    TWiki::Store::RcsFile::saveFile( $this, $this->{file}, $text );
156    require TWiki::Time;
157	$date = TWiki::Time::formatTime( $date , '$rcs', 'gmtime');
158
159    _lock( $this );
160    my ($rcsOut, $exit) =
161      $TWiki::sandbox->sysCommand(
162          $TWiki::cfg{RCS}{ciDateCmd},
163          DATE => $date,
164          USERNAME => $user,
165          FILENAME => $this->{file},
166          COMMENT => $comment );
167    if( $exit ) {
168        $rcsOut = $TWiki::cfg{RCS}{ciDateCmd}."\n".$rcsOut;
169        return $rcsOut;
170    }
171    chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
172}
173
174# implements RcsFile
175sub deleteRevision {
176    my( $this ) = @_;
177    my $rev = $this->numRevisions();
178    return undef if( $rev <= 1 );
179    return _deleteRevision( $this, $rev );
180}
181
182sub _deleteRevision {
183    my( $this, $rev ) = @_;
184
185    # delete latest revision (unlock (may not be needed), delete revision)
186    my ($rcsOut, $exit) =
187      $TWiki::sandbox->sysCommand(
188          $TWiki::cfg{RCS}{unlockCmd},
189          FILENAME => $this->{file} );
190
191    chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
192
193    ($rcsOut, $exit) = $TWiki::sandbox->sysCommand(
194        $TWiki::cfg{RCS}{delRevCmd},
195        REVISION => '1.'.$rev,
196        FILENAME => $this->{file} );
197
198    if( $exit ) {
199        throw Error::Simple( $TWiki::cfg{RCS}{delRevCmd}.
200                               ' of '.$this->hidePath($this->{file}).
201                                 ' failed: '.$rcsOut );
202    }
203
204    # Update the checkout
205    $rev--;
206    ($rcsOut, $exit) = $TWiki::sandbox->sysCommand(
207        $TWiki::cfg{RCS}{coCmd},
208        REVISION => '1.'.$rev,
209        FILENAME => $this->{file} );
210
211    if( $exit ) {
212        throw Error::Simple( $TWiki::cfg{RCS}{coCmd}.
213                               ' of '.$this->hidePath($this->{file}).
214                                 ' failed: '.$rcsOut );
215    }
216    TWiki::Store::RcsFile::saveFile( $this, $this->{file}, $rcsOut );
217}
218
219# implements RcsFile
220sub getRevision {
221    my( $this, $version ) = @_;
222
223    unless( $version && -e $this->{rcsFile} ) {
224        return $this->SUPER::getRevision( $version );
225    }
226
227    my $tmpfile = '';
228    my $tmpRevFile = '';
229    my $coCmd = $TWiki::cfg{RCS}{coCmd};
230    my $file = $this->{file};
231    if( $TWiki::cfg{RCS}{coMustCopy} ) {
232        # SMELL: is this really necessary? What evidence is there?
233        # Need to take temporary copy of topic, check it out to file,
234        # then read that
235        # Need to put RCS into binary mode to avoid extra \r appearing and
236        # read from binmode file rather than stdout to avoid early file
237        # read termination
238        $tmpfile = TWiki::Store::RcsFile::mkTmpFilename( $this );
239        $tmpRevFile = $tmpfile.',v';
240        copy( $this->{rcsFile}, $tmpRevFile );
241        my ($tmp, $status) = $TWiki::sandbox->sysCommand(
242            $TWiki::cfg{RCS}{tmpBinaryCmd},
243            FILENAME => $tmpRevFile );
244        $file = $tmpfile;
245        $coCmd =~ s/-p%REVISION/-r%REVISION/;
246    }
247    my ($text, $status) = $TWiki::sandbox->sysCommand(
248        $coCmd,
249        REVISION => '1.'.$version,
250        FILENAME => $file );
251
252    if( $tmpfile ) {
253        $text = TWiki::Store::RcsFile::readFile( $this, $tmpfile );
254        # SMELL: Is untainting really necessary here?
255        unlink TWiki::Sandbox::untaintUnchecked( $tmpfile );
256        unlink TWiki::Sandbox::untaintUnchecked( $tmpRevFile );
257    }
258
259    return $text;
260}
261
262# implements RcsFile
263sub numRevisions {
264    my( $this ) = @_;
265
266    if ( -e $this->{rcsFile} && -s $this->{rcsFile} == 0 ) {
267        $this->{session}->writeWarning('null RCS: ' . $this->{rcsFile});
268        $this->{session}{rcsFileNull} = 1;
269        unlink $this->{rcsFile};
270    }
271    unless( -e $this->{rcsFile}) {
272        return 1 if( -e $this->{file} );
273        return 0;
274    }
275
276    my ($rcsOutput, $exit) =
277      $TWiki::sandbox->sysCommand
278        ( $TWiki::cfg{RCS}{histCmd},
279          FILENAME => $this->{rcsFile} );
280    if( $exit ) {
281        throw Error::Simple( 'RCS: '.$TWiki::cfg{RCS}{histCmd}.
282                               ' of '.$this->hidePath($this->{rcsFile}).
283                                 ' failed: '.$rcsOutput );
284    }
285    if( $rcsOutput =~ /head:\s+\d+\.(\d+)\n/ ) {
286        return $1;
287    }
288    if( $rcsOutput =~ /total revisions: (\d+)\n/ ) {
289        return $1;
290    }
291    return 1;
292}
293
294# implements RcsFile
295sub getRevisionInfo {
296    my( $this, $version ) = @_;
297
298    if( -e $this->{rcsFile} ) {
299        if( !$version || $version > $this->numRevisions()) {
300            $version = $this->numRevisions();
301        }
302        my( $rcsOut, $exit ) = $TWiki::sandbox->sysCommand
303          ( $TWiki::cfg{RCS}{infoCmd},
304            REVISION => '1.'.$version,
305            FILENAME => $this->{rcsFile} );
306        if( ! $exit ) {
307            if( $rcsOut =~ /^.*?date: ([^;]+);  author: ([^;]*);[^\n]*\n([^\n]*)\n/s ) {
308                my $user = $2;
309                my $comment = $3;
310                require TWiki::Time;
311                my $date = TWiki::Time::parseTime( $1 );
312                my $rev = $version;
313                if( $rcsOut =~ /revision 1.([0-9]*)/ ) {
314                    $rev = $1;
315                    return( $rev, $date, $user, $comment );
316                }
317            }
318        }
319    }
320
321    return $this->SUPER::getRevisionInfo( $version );
322}
323
324# implements RcsFile
325sub revisionDiff {
326    my( $this, $rev1, $rev2, $contextLines ) = @_;
327    my $tmp = '';
328    my $exit;
329    if ( $rev1 eq '1' && $rev2 eq '1' ) {
330        my $text = $this->getRevision(1);
331        $tmp = "1a1\n";
332        foreach( split( /\r?\n/, $text ) ) {
333            $tmp = "$tmp> $_\n";
334        }
335    } else {
336        $contextLines = 3 unless defined($contextLines);
337        ( $tmp, $exit ) = $TWiki::sandbox->sysCommand(
338            $TWiki::cfg{RCS}{diffCmd},
339            REVISION1 => '1.'.$rev1,
340            REVISION2 => '1.'.$rev2,
341            FILENAME => $this->{rcsFile},
342            CONTEXT => $contextLines );
343        # comment out because we get a non-zero status for a good result!
344        #if( $exit ) {
345        #    throw Error::Simple( 'RCS: '.$TWiki::cfg{RCS}{diffCmd}.
346        #                           ' failed: '.$! );
347        #}
348    }
349
350    return parseRevisionDiff( $tmp );
351}
352
353=pod
354
355---++ StaticMethod parseRevisionDiff( $text ) -> \@diffArray
356
357| Description: | parse the text into an array of diff cells |
358| #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) |
359| Parameter: =$text= | currently unified or rcsdiff format |
360| Return: =\@diffArray= | reference to an array of [ diffType, $right, $left ] |
361| TODO: | move into RcsFile and add indirection in Store |
362
363=cut
364
365sub parseRevisionDiff {
366    my( $text ) = @_;
367
368    my ( $diffFormat ) = 'normal'; #or rcs, unified...
369    my ( @diffArray ) = ();
370
371    $diffFormat = 'unified' if ( $text =~ /^---/s );
372
373    $text =~ s/\r//go;  # cut CR
374
375    my $lineNumber=1;
376    if ( $diffFormat eq 'unified' ) {
377        foreach( split( /\r?\n/, $text ) ) {
378            if ( $lineNumber > 2 ) {   #skip the first 2 lines (filenames)
379                if ( /@@ [-+]([0-9]+)([,0-9]+)? [-+]([0-9]+)(,[0-9]+)? @@/ ) {
380	    	        #line number
381                    push @diffArray, ['l', $1, $3];
382                } elsif( /^\-(.*)$/ ) {
383                    push @diffArray, ['-', $1, ''];
384                } elsif( /^\+(.*)$/ ) {
385                    push @diffArray, ['+', '', $1];
386                } else {
387                    s/^ (.*)$/$1/go;
388                    push @diffArray, ['u', $_, $_];
389                }
390            }
391            $lineNumber++;
392        }
393    } else {
394        #'normal' rcsdiff output
395        foreach( split( /\r?\n/, $text ) ) {
396    	    if ( /^([0-9]+)[0-9\,]*([acd])([0-9]+)/ ) {
397    	        #line number
398                push @diffArray, ['l', $1, $3];
399            } elsif( /^< (.*)$/ ) {
400	            push @diffArray, ['-', $1, ''];
401            } elsif( /^> (.*)$/ ) {
402	            push @diffArray, ['+', '', $1];
403            } else {
404                #push @diffArray, ['u', '', ''];
405            }
406        }
407    }
408    return \@diffArray;
409}
410
411sub _ci {
412    my( $this, $comment, $user, $date ) = @_;
413
414    $comment = 'none' unless $comment;
415
416    # Item7765
417    my $semaphoreFile = $this->{file};
418    $semaphoreFile =~ s:^(.*/)(.*):$1,$2,:;
419    unlink $semaphoreFile;
420
421    my( $cmd, $rcsOutput, $exit );
422    if( defined( $date )) {
423        require TWiki::Time;
424        $date = TWiki::Time::formatTime( $date , '$rcs', 'gmtime');
425        $cmd = $TWiki::cfg{RCS}{ciDateCmd};
426        ($rcsOutput, $exit)= $TWiki::sandbox->sysCommand(
427            $cmd,
428            USERNAME => $user,
429            FILENAME => $this->{file},
430            COMMENT => $comment,
431            DATE => $date );
432    } else {
433        $cmd = $TWiki::cfg{RCS}{ciCmd};
434        ($rcsOutput, $exit)= $TWiki::sandbox->sysCommand(
435            $cmd,
436            USERNAME => $user,
437            FILENAME => $this->{file},
438            COMMENT => $comment );
439    }
440    $rcsOutput ||= '';
441
442    if( $exit ) {
443        throw Error::Simple($cmd.' of '.$this->hidePath($this->{file}).
444                              ' failed: '.$exit.' '.$rcsOutput );
445    }
446
447    chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
448}
449
450sub _lock {
451    my $this = shift;
452
453    return unless -e $this->{rcsFile};
454
455    # Item7765
456    my $semaphoreFile = $this->{file};
457    $semaphoreFile =~ s:^(.*/)(.*):$1,$2,:;
458    unlink $semaphoreFile;
459
460    # Try and get a lock on the file
461    my ($rcsOutput, $exit) = $TWiki::sandbox->sysCommand(
462        $TWiki::cfg{RCS}{lockCmd}, FILENAME => $this->{file} );
463
464    if( $exit ) {
465        # if the lock has been set more than 24h ago, let's try to break it
466        # and then retry.  Should not happen unless in Cairo upgrade
467        # scenarios - see Item2102
468        if ((time - (stat($this->{rcsFile}))[9]) > 3600) {
469            warn 'Automatic recovery: breaking lock for ' . $this->{file} ;
470            $TWiki::sandbox->sysCommand(
471                $TWiki::cfg{RCS}{breaklockCmd}, FILENAME => $this->{file} );
472        ($rcsOutput, $exit) = $TWiki::sandbox->sysCommand(
473                $TWiki::cfg{RCS}{lockCmd}, FILENAME => $this->{file} );
474        }
475       if ( $exit ) {
476           # still no luck - bailing out
477           $rcsOutput ||= '';
478           throw Error::Simple( 'RCS: '.$TWiki::cfg{RCS}{lockCmd}.
479                                ' failed: '.$rcsOutput );
480       }
481    }
482    chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
483}
484
485# implements RcsFile
486sub getRevisionAtTime {
487    my( $this, $date ) = @_;
488
489    if ( !-e $this->{rcsFile} ) {
490        return undef;
491    }
492    require TWiki::Time;
493	$date = TWiki::Time::formatTime( $date , '$rcs', 'gmtime');
494    my ($rcsOutput, $exit) = $TWiki::sandbox->sysCommand(
495        $TWiki::cfg{RCS}{rlogDateCmd},
496        DATE => $date,
497        FILENAME => $this->{file} );
498
499    if ( $rcsOutput =~ m/revision \d+\.(\d+)/ ) {
500        return $1;
501    }
502    return 1;
503}
504
5051;
506