490 lines
15 KiB
Perl
490 lines
15 KiB
Perl
# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
|
|
#
|
|
# Copyright (C) 2002 John Talintyre, john.talintyre@btinternet.com
|
|
# Copyright (C) 2002-2007 Peter Thoeny, peter@thoeny.org
|
|
# and TWiki Contributors. All Rights Reserved. TWiki Contributors
|
|
# are listed in the AUTHORS file in the root of this distribution.
|
|
# NOTE: Please extend that file, not this notice.
|
|
#
|
|
# This program is free software; you can redistribute it and/or
|
|
# modify it under the terms of the GNU General Public License
|
|
# as published by the Free Software Foundation; either version 2
|
|
# of the License, or (at your option) any later version. For
|
|
# more details read LICENSE in the root of this distribution.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
#
|
|
# As per the GPL, removal of this notice is prohibited.
|
|
|
|
=pod
|
|
|
|
---+ package TWiki::Store::RcsWrap
|
|
|
|
This package does not publish any methods. It implements the
|
|
virtual methods of the [[TWikiStoreRcsFileDotPm][TWiki::Store::RcsFile]] superclass.
|
|
|
|
Wrapper around the RCS commands required by TWiki.
|
|
There is one of these object for each file stored under RCS.
|
|
|
|
=cut
|
|
|
|
package TWiki::Store::RcsWrap;
|
|
|
|
use TWiki;
|
|
use File::Copy;
|
|
use TWiki::Store::RcsFile;
|
|
use TWiki::Time;
|
|
|
|
@ISA = qw(TWiki::Store::RcsFile);
|
|
|
|
use strict;
|
|
use Assert;
|
|
|
|
# implements RcsFile
|
|
sub new {
|
|
my( $class, $session, $web, $topic, $attachment ) = @_;
|
|
ASSERT($session->isa( 'TWiki')) if DEBUG;
|
|
my $this =
|
|
bless( new TWiki::Store::RcsFile( $session, $web, $topic, $attachment ),
|
|
$class );
|
|
return $this;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod finish
|
|
Complete processing after the client's HTTP request has been responded
|
|
to.
|
|
1 breaking circular references to allow garbage collection in persistent
|
|
environments
|
|
|
|
=cut
|
|
|
|
sub finish {
|
|
my $this = shift;
|
|
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub initBinary {
|
|
my( $this ) = @_;
|
|
|
|
$this->{binary} = 1;
|
|
|
|
TWiki::Store::RcsFile::_mkPathTo( $this->{file} );
|
|
|
|
return if -e $this->{rcsFile};
|
|
|
|
my ( $rcsOutput, $exit ) =
|
|
$this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{initBinaryCmd}, FILENAME => $this->{file} );
|
|
if( $exit ) {
|
|
throw Error::Simple( $TWiki::cfg{RCS}{initBinaryCmd}.
|
|
' of '.$this->_hidePath($this->{file}).
|
|
' failed: '.$rcsOutput );
|
|
} elsif( ! -e $this->{rcsFile} ) {
|
|
# Sometimes (on Windows?) rcs file not formed, so check for it
|
|
throw Error::Simple( $TWiki::cfg{RCS}{initBinaryCmd}.
|
|
' of '.$this->_hidePath($this->{rcsFile}).
|
|
' failed to create history file ');
|
|
}
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub initText {
|
|
my( $this ) = @_;
|
|
|
|
$this->{binary} = 0;
|
|
|
|
TWiki::Store::RcsFile::_mkPathTo( $this->{file} );
|
|
|
|
return if -e $this->{rcsFile};
|
|
|
|
my ( $rcsOutput, $exit ) =
|
|
$this->{session}->{sandbox}->sysCommand
|
|
( $TWiki::cfg{RCS}{initTextCmd},
|
|
FILENAME => $this->{file} );
|
|
if( $exit ) {
|
|
$rcsOutput ||= '';
|
|
throw Error::Simple( $TWiki::cfg{RCS}{initTextCmd}.
|
|
' of '.$this->_hidePath($this->{file}).
|
|
' failed: '.$rcsOutput );
|
|
} elsif( ! -e $this->{rcsFile} ) {
|
|
# Sometimes (on Windows?) rcs file not formed, so check for it
|
|
throw Error::Simple( $TWiki::cfg{RCS}{initTextCmd}.
|
|
' of '.$this->_hidePath($this->{rcsFile}).
|
|
' failed to create history file ');
|
|
}
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub addRevisionFromText {
|
|
my( $this, $text, $comment, $user, $date ) = @_;
|
|
$this->init();
|
|
|
|
unless( -e $this->{rcsFile} ) {
|
|
$this->_lock();
|
|
$this->_ci( $comment, $user, $date );
|
|
}
|
|
$this->_saveFile( $this->{file}, $text );
|
|
$this->_lock();
|
|
$this->_ci( $comment, $user, $date );
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub addRevisionFromStream {
|
|
my( $this, $stream, $comment, $user, $date ) = @_;
|
|
$this->init();
|
|
|
|
$this->_lock();
|
|
$this->_saveStream( $stream );
|
|
$this->_ci( $comment, $user, $date );
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub replaceRevision {
|
|
my( $this, $text, $comment, $user, $date ) = @_;
|
|
|
|
my $rev = $this->numRevisions();
|
|
|
|
$comment ||= 'none';
|
|
|
|
# update repository with same userName and date
|
|
if( $rev == 1 ) {
|
|
# initial revision, so delete repository file and start again
|
|
unlink $this->{rcsFile};
|
|
} else {
|
|
$this->_deleteRevision( $rev );
|
|
}
|
|
$this->_saveFile( $this->{file}, $text );
|
|
$date = TWiki::Time::formatTime( $date , '$rcs', 'gmtime');
|
|
|
|
$this->_lock();
|
|
my ($rcsOut, $exit) =
|
|
$this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{ciDateCmd},
|
|
DATE => $date,
|
|
USERNAME => $user,
|
|
FILENAME => $this->{file},
|
|
COMMENT => $comment );
|
|
if( $exit ) {
|
|
$rcsOut = $TWiki::cfg{RCS}{ciDateCmd}."\n".$rcsOut;
|
|
return $rcsOut;
|
|
}
|
|
chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub deleteRevision {
|
|
my( $this ) = @_;
|
|
my $rev = $this->numRevisions();
|
|
return undef if( $rev <= 1 );
|
|
return $this->_deleteRevision( $rev );
|
|
}
|
|
|
|
sub _deleteRevision {
|
|
my( $this, $rev ) = @_;
|
|
|
|
# delete latest revision (unlock (may not be needed), delete revision)
|
|
my ($rcsOut, $exit) =
|
|
$this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{unlockCmd},
|
|
FILENAME => $this->{file} );
|
|
|
|
chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
|
|
|
|
($rcsOut, $exit) = $this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{delRevCmd},
|
|
REVISION => '1.'.$rev,
|
|
FILENAME => $this->{file} );
|
|
|
|
if( $exit ) {
|
|
throw Error::Simple( $TWiki::cfg{RCS}{delRevCmd}.
|
|
' of '.$this->_hidePath($this->{file}).
|
|
' failed: '.$rcsOut );
|
|
}
|
|
|
|
# Update the checkout
|
|
$rev--;
|
|
($rcsOut, $exit) = $this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{coCmd},
|
|
REVISION => '1.'.$rev,
|
|
FILENAME => $this->{file} );
|
|
|
|
if( $exit ) {
|
|
throw Error::Simple( $TWiki::cfg{RCS}{coCmd}.
|
|
' of '.$this->_hidePath($this->{file}).
|
|
' failed: '.$rcsOut );
|
|
}
|
|
$this->_saveFile( $this->{file}, $rcsOut );
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub getRevision {
|
|
my( $this, $version ) = @_;
|
|
|
|
unless( $version && -e $this->{rcsFile} ) {
|
|
return $this->SUPER::getRevision( $version );
|
|
}
|
|
|
|
my $tmpfile = '';
|
|
my $tmpRevFile = '';
|
|
my $coCmd = $TWiki::cfg{RCS}{coCmd};
|
|
my $file = $this->{file};
|
|
if( $TWiki::cfg{RCS}{coMustCopy} ) {
|
|
# Need to take temporary copy of topic, check it out to file,
|
|
# then read that
|
|
# Need to put RCS into binary mode to avoid extra \r appearing and
|
|
# read from binmode file rather than stdout to avoid early file
|
|
# read termination
|
|
$tmpfile = $this->_mkTmpFilename();
|
|
$tmpRevFile = $tmpfile.',v';
|
|
copy( $this->{rcsFile}, $tmpRevFile );
|
|
my ($tmp, $status) = $this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{tmpBinaryCmd},
|
|
FILENAME => $tmpRevFile );
|
|
$file = $tmpfile;
|
|
$coCmd =~ s/-p%REVISION/-r%REVISION/;
|
|
}
|
|
my ($text, $status) = $this->{session}->{sandbox}->sysCommand(
|
|
$coCmd,
|
|
REVISION => '1.'.$version,
|
|
FILENAME => $file );
|
|
|
|
if( $tmpfile ) {
|
|
$text = $this->_readFile( $tmpfile );
|
|
# SMELL: Is untainting really necessary here?
|
|
unlink TWiki::Sandbox::untaintUnchecked( $tmpfile );
|
|
unlink TWiki::Sandbox::untaintUnchecked( $tmpRevFile );
|
|
}
|
|
|
|
return $text;
|
|
}
|
|
|
|
sub numRevisions {
|
|
my( $this ) = @_;
|
|
|
|
unless( -e $this->{rcsFile}) {
|
|
return 1 if( -e $this->{file} );
|
|
return 0;
|
|
}
|
|
|
|
my ($rcsOutput, $exit) =
|
|
$this->{session}->{sandbox}->sysCommand
|
|
( $TWiki::cfg{RCS}{histCmd},
|
|
FILENAME => $this->{rcsFile} );
|
|
if( $exit ) {
|
|
throw Error::Simple( 'RCS: '.$TWiki::cfg{RCS}{histCmd}.
|
|
' of '.$this->_hidePath($this->{rcsFile}).
|
|
' failed: '.$rcsOutput );
|
|
}
|
|
if( $rcsOutput =~ /head:\s+\d+\.(\d+)\n/ ) {
|
|
return $1;
|
|
}
|
|
if( $rcsOutput =~ /total revisions: (\d+)\n/ ) {
|
|
return $1;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub getRevisionInfo {
|
|
my( $this, $version ) = @_;
|
|
|
|
if( -e $this->{rcsFile} ) {
|
|
if( !$version || $version > $this->numRevisions()) {
|
|
$version = $this->numRevisions();
|
|
}
|
|
my( $rcsOut, $exit ) = $this->{session}->{sandbox}->sysCommand
|
|
( $TWiki::cfg{RCS}{infoCmd},
|
|
REVISION => '1.'.$version,
|
|
FILENAME => $this->{rcsFile} );
|
|
if( ! $exit ) {
|
|
if( $rcsOut =~ /^.*?date: ([^;]+); author: ([^;]*);[^\n]*\n([^\n]*)\n/s ) {
|
|
my $user = $2;
|
|
my $comment = $3;
|
|
my $date = TWiki::Time::parseTime( $1 );
|
|
my $rev = $version;
|
|
if( $rcsOut =~ /revision 1.([0-9]*)/ ) {
|
|
$rev = $1;
|
|
return( $rev, $date, $user, $comment );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return $this->SUPER::getRevisionInfo( $version );
|
|
}
|
|
|
|
# implements RcsFile
|
|
sub revisionDiff {
|
|
my( $this, $rev1, $rev2, $contextLines ) = @_;
|
|
my $tmp = '';
|
|
my $exit;
|
|
if ( $rev1 eq '1' && $rev2 eq '1' ) {
|
|
my $text = $this->getRevision(1);
|
|
$tmp = "1a1\n";
|
|
foreach( split( /\r?\n/, $text ) ) {
|
|
$tmp = "$tmp> $_\n";
|
|
}
|
|
} else {
|
|
$contextLines = 3 unless defined($contextLines);
|
|
( $tmp, $exit ) = $this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{diffCmd},
|
|
REVISION1 => '1.'.$rev1,
|
|
REVISION2 => '1.'.$rev2,
|
|
FILENAME => $this->{rcsFile},
|
|
CONTEXT => $contextLines );
|
|
# comment out because we get a non-zero status for a good result!
|
|
#if( $exit ) {
|
|
# throw Error::Simple( 'RCS: '.$TWiki::cfg{RCS}{diffCmd}.
|
|
# ' failed: '.$! );
|
|
#}
|
|
}
|
|
|
|
return parseRevisionDiff( $tmp );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ StaticMethod parseRevisionDiff( $text ) -> \@diffArray
|
|
|
|
| Description: | parse the text into an array of diff cells |
|
|
| #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) |
|
|
| Parameter: =$text= | currently unified or rcsdiff format |
|
|
| Return: =\@diffArray= | reference to an array of [ diffType, $right, $left ] |
|
|
| TODO: | move into RcsFile and add indirection in Store |
|
|
|
|
=cut
|
|
|
|
sub parseRevisionDiff {
|
|
my( $text ) = @_;
|
|
|
|
my ( $diffFormat ) = 'normal'; #or rcs, unified...
|
|
my ( @diffArray ) = ();
|
|
|
|
$diffFormat = 'unified' if ( $text =~ /^---/s );
|
|
|
|
$text =~ s/\r//go; # cut CR
|
|
|
|
my $lineNumber=1;
|
|
if ( $diffFormat eq 'unified' ) {
|
|
foreach( split( /\r?\n/, $text ) ) {
|
|
if ( $lineNumber > 2 ) { #skip the first 2 lines (filenames)
|
|
if ( /@@ [-+]([0-9]+)([,0-9]+)? [-+]([0-9]+)(,[0-9]+)? @@/ ) {
|
|
#line number
|
|
push @diffArray, ['l', $1, $3];
|
|
} elsif( /^\-(.*)$/ ) {
|
|
push @diffArray, ['-', $1, ''];
|
|
} elsif( /^\+(.*)$/ ) {
|
|
push @diffArray, ['+', '', $1];
|
|
} else {
|
|
s/^ (.*)$/$1/go;
|
|
push @diffArray, ['u', $_, $_];
|
|
}
|
|
}
|
|
$lineNumber++;
|
|
}
|
|
} else {
|
|
#'normal' rcsdiff output
|
|
foreach( split( /\r?\n/, $text ) ) {
|
|
if ( /^([0-9]+)[0-9\,]*([acd])([0-9]+)/ ) {
|
|
#line number
|
|
push @diffArray, ['l', $1, $3];
|
|
} elsif( /^< (.*)$/ ) {
|
|
push @diffArray, ['-', $1, ''];
|
|
} elsif( /^> (.*)$/ ) {
|
|
push @diffArray, ['+', '', $1];
|
|
} else {
|
|
#push @diffArray, ['u', '', ''];
|
|
}
|
|
}
|
|
}
|
|
return \@diffArray;
|
|
}
|
|
|
|
sub _ci {
|
|
my( $this, $comment, $user, $date ) = @_;
|
|
|
|
$comment = 'none' unless $comment;
|
|
|
|
my( $cmd, $rcsOutput, $exit );
|
|
if( defined( $date )) {
|
|
$date = TWiki::Time::formatTime( $date , '$rcs', 'gmtime');
|
|
$cmd = $TWiki::cfg{RCS}{ciDateCmd};
|
|
($rcsOutput, $exit)= $this->{session}->{sandbox}->sysCommand(
|
|
$cmd,
|
|
USERNAME => $user,
|
|
FILENAME => $this->{file},
|
|
COMMENT => $comment,
|
|
DATE => $date );
|
|
} else {
|
|
$cmd = $TWiki::cfg{RCS}{ciCmd};
|
|
($rcsOutput, $exit)= $this->{session}->{sandbox}->sysCommand(
|
|
$cmd,
|
|
USERNAME => $user,
|
|
FILENAME => $this->{file},
|
|
COMMENT => $comment );
|
|
}
|
|
$rcsOutput ||= '';
|
|
|
|
if( $exit ) {
|
|
throw Error::Simple($cmd.' of '.$this->_hidePath($this->{file}).
|
|
' failed: '.$exit.' '.$rcsOutput );
|
|
}
|
|
|
|
chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
|
|
}
|
|
|
|
sub _lock {
|
|
my $this = shift;
|
|
|
|
return unless -e $this->{rcsFile};
|
|
|
|
# Try and get a lock on the file
|
|
my ($rcsOutput, $exit) = $this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{lockCmd}, FILENAME => $this->{file} );
|
|
|
|
if( $exit ) {
|
|
# if the lock has been set more than 24h ago, let's try to break it
|
|
# and then retry. Should not happen unless in Cairo upgrade
|
|
# scenarios - see Item2102
|
|
if ((time - (stat($this->{rcsFile}))[9]) > 3600) {
|
|
warn 'Automatic recovery: breaking lock for ' . $this->{file} ;
|
|
$this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{breaklockCmd}, FILENAME => $this->{file} );
|
|
($rcsOutput, $exit) = $this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{lockCmd}, FILENAME => $this->{file} );
|
|
}
|
|
if ( $exit ) {
|
|
# still no luck - bailing out
|
|
$rcsOutput ||= '';
|
|
throw Error::Simple( 'RCS: '.$TWiki::cfg{RCS}{lockCmd}.
|
|
' failed: '.$rcsOutput );
|
|
}
|
|
}
|
|
chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
|
|
}
|
|
|
|
sub getRevisionAtTime {
|
|
my( $this, $date ) = @_;
|
|
|
|
if ( !-e $this->{rcsFile} ) {
|
|
return undef;
|
|
}
|
|
$date = TWiki::Time::formatTime( $date , '$rcs', 'gmtime');
|
|
my ($rcsOutput, $exit) = $this->{session}->{sandbox}->sysCommand(
|
|
$TWiki::cfg{RCS}{rlogDateCmd},
|
|
DATE => $date,
|
|
FILENAME => $this->{file} );
|
|
|
|
if ( $rcsOutput =~ m/revision \d+\.(\d+)/ ) {
|
|
return $1;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
1;
|