1114 lines
26 KiB
Perl
1114 lines
26 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::RcsFile
|
|
|
|
This class is PACKAGE PRIVATE to Store, and should never be
|
|
used from anywhere else. Base class of implementations of stores
|
|
that manipulate RCS format files.
|
|
|
|
The general contract of the methods on this class and its subclasses
|
|
calls for errors to be signalled by Error::Simple exceptions.
|
|
|
|
Refer to Store.pm for models of usage.
|
|
|
|
=cut
|
|
|
|
package TWiki::Store::RcsFile;
|
|
|
|
use strict;
|
|
|
|
use File::Copy;
|
|
use File::Spec;
|
|
use File::Path;
|
|
use File::Basename;
|
|
use Assert;
|
|
use TWiki::Time;
|
|
use TWiki::Sandbox;
|
|
|
|
=pod
|
|
|
|
---++ ClassMethod new($session, $web, $topic, $attachment)
|
|
|
|
Constructor. There is one object per stored file.
|
|
|
|
Note that $web, $topic and $attachment must be untainted!
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my( $class, $session, $web, $topic, $attachment ) = @_;
|
|
#ASSERT($session->isa( 'TWiki')) if DEBUG;
|
|
my $this = bless( {}, $class );
|
|
$this->{session} = $session;
|
|
|
|
$this->{web} = $web;
|
|
|
|
if( $topic ) {
|
|
my $rcsSubDir = ( $TWiki::cfg{RCS}{useSubDir} ? '/RCS' : '' );
|
|
|
|
$this->{topic} = $topic;
|
|
|
|
if( $attachment ) {
|
|
|
|
$this->{attachment} = $attachment;
|
|
|
|
$this->{file} = $TWiki::cfg{PubDir}.'/'.$web.'/'.
|
|
$this->{topic}.'/'.$attachment;
|
|
$this->{rcsFile} = $TWiki::cfg{PubDir}.'/'.
|
|
$web.'/'.$topic.$rcsSubDir.'/'.$attachment.',v';
|
|
|
|
} else {
|
|
$this->{file} = $TWiki::cfg{DataDir}.'/'.$web.'/'.
|
|
$topic.'.txt';
|
|
$this->{rcsFile} = $TWiki::cfg{DataDir}.'/'.
|
|
$web.$rcsSubDir.'/'.$topic.'.txt,v';
|
|
}
|
|
}
|
|
|
|
return $this;
|
|
}
|
|
|
|
# Used in subclasses for late initialisation during object creation
|
|
# (after the object is blessed into the subclass)
|
|
sub init {
|
|
my $this = shift;
|
|
|
|
return unless $this->{topic};
|
|
|
|
unless( -e $this->{file} ) {
|
|
if( $this->{attachment} && !$this->isAsciiDefault() ) {
|
|
$this->initBinary();
|
|
} else {
|
|
$this->initText();
|
|
}
|
|
}
|
|
}
|
|
|
|
# Make any missing paths on the way to this file
|
|
# SMELL: duplicates CPAN File::Tree::mkpath
|
|
sub _mkPathTo {
|
|
|
|
my $file = shift;
|
|
|
|
$file = TWiki::Sandbox::untaintUnchecked( $file );
|
|
my $path = File::Basename::dirname($file);
|
|
eval {
|
|
File::Path::mkpath($path, 0, $TWiki::cfg{RCS}{dirPermission});
|
|
};
|
|
if ($@) {
|
|
throw Error::Simple("RCS: failed to create ${path}: $!");
|
|
}
|
|
}
|
|
|
|
# SMELL: this should use TWiki::Time
|
|
sub _epochToRcsDateTime {
|
|
my( $dateTime ) = @_;
|
|
# TODO: should this be gmtime or local time?
|
|
my( $sec,$min,$hour,$mday,$mon,$year,$wday,$yday ) = gmtime( $dateTime );
|
|
$year += 1900 if( $year > 99 );
|
|
my $rcsDateTime = sprintf '%d.%02d.%02d.%02d.%02d.%02d',
|
|
( $year, $mon + 1, $mday, $hour, $min, $sec );
|
|
return $rcsDateTime;
|
|
}
|
|
|
|
# filenames for lock and lease files
|
|
sub _controlFileName {
|
|
my( $this, $type ) = @_;
|
|
|
|
my $fn = $this->{file} || '';
|
|
$fn =~ s/txt$/$type/;
|
|
return $fn;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getRevisionInfo($version) -> ($rev, $date, $user, $comment)
|
|
|
|
* =$version= if 0 or undef, or out of range (version number > number of revs) will return info about the latest revision.
|
|
|
|
Returns (rev, date, user, comment) where rev is the number of the rev for which the info was recovered, date is the date of that rev (epoch s), user is the login name of the user who saved that rev, and comment is the comment associated with the rev.
|
|
|
|
Designed to be overridden by subclasses, which can call up to this method
|
|
if file-based rev info is required.
|
|
|
|
=cut
|
|
|
|
sub getRevisionInfo {
|
|
my( $this ) = @_;
|
|
my $fileDate = $this->getTimestamp();
|
|
return ( 1, $fileDate, $TWiki::cfg{DefaultUserLogin},
|
|
'Default revision information' );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getLatestRevision() -> $text
|
|
|
|
Get the text of the most recent revision
|
|
|
|
=cut
|
|
|
|
sub getLatestRevision {
|
|
my $this = shift;
|
|
return $this->_readFile( $this->{file} );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getLatestRevisionTime() -> $text
|
|
|
|
Get the time of the most recent revision
|
|
|
|
=cut
|
|
|
|
sub getLatestRevisionTime {
|
|
my @e = stat( shift->{file} );
|
|
return $e[9] || 0;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod readMetaData($name) -> $text
|
|
|
|
Get a meta-data block for this web
|
|
|
|
=cut
|
|
|
|
sub readMetaData {
|
|
my( $this, $name ) = @_;
|
|
my $file = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/.'.$name;
|
|
if( -e $file ) {
|
|
return $this->_readFile( $file );
|
|
}
|
|
return '';
|
|
}
|
|
|
|
=pod
|
|
|
|
---+++ ObjectMethod getWorkArea( $key ) -> $directorypath
|
|
|
|
Gets a private directory uniquely identified by $key. The directory is
|
|
intended as a work area for plugins.
|
|
|
|
The standard is a directory named the same as "key" under
|
|
$TWiki::cfg{RCS}{WorkAreaDir}
|
|
|
|
=cut
|
|
|
|
sub getWorkArea {
|
|
my( $this, $key ) = @_;
|
|
|
|
# untaint and detect nasties
|
|
$key = TWiki::Sandbox::normalizeFileName( $key );
|
|
throw Error::Simple( "Bad work area name $key" ) unless ( $key );
|
|
|
|
my $dir = "$TWiki::cfg{RCS}{WorkAreaDir}/$key";
|
|
|
|
unless( -d $dir ) {
|
|
mkdir( $dir ) || throw Error::Simple(
|
|
'RCS: failed to create '.$key.'work area: '.$! );
|
|
}
|
|
return $dir;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod saveMetaData( $web, $name ) -> $text
|
|
|
|
Write a named meta-data string. If web is given the meta-data
|
|
is stored alongside a web.
|
|
|
|
=cut
|
|
|
|
sub saveMetaData {
|
|
my ( $this, $name, $text ) = @_;
|
|
|
|
my $file = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/.'.$name;
|
|
|
|
return $this->_saveFile( $file, $text );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getTopicNames() -> @topics
|
|
|
|
Get list of all topics in a web
|
|
* =$web= - Web name, required, e.g. ='Sandbox'=
|
|
Return a topic list, e.g. =( 'WebChanges', 'WebHome', 'WebIndex', 'WebNotify' )=
|
|
|
|
=cut
|
|
|
|
sub getTopicNames {
|
|
my $this = shift;
|
|
|
|
opendir DIR, $TWiki::cfg{DataDir}.'/'.$this->{web};
|
|
# the name filter is used to ensure we don't return filenames
|
|
# that contain illegal characters as topic names.
|
|
my @topicList =
|
|
sort
|
|
map { TWiki::Sandbox::untaintUnchecked( $_ ) }
|
|
grep { !/$TWiki::cfg{NameFilter}/ && s/\.txt$// }
|
|
readdir( DIR );
|
|
closedir( DIR );
|
|
return @topicList;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getWebNames() -> @webs
|
|
|
|
Gets a list of names of subwebs in the current web
|
|
|
|
=cut
|
|
|
|
sub getWebNames {
|
|
my $this = shift;
|
|
my $dir = $TWiki::cfg{DataDir}.'/'.$this->{web};
|
|
if( opendir( DIR, $dir ) ) {
|
|
my @tmpList =
|
|
sort
|
|
map { TWiki::Sandbox::untaintUnchecked( $_ ) }
|
|
grep { !/\./ &&
|
|
!/$TWiki::cfg{NameFilter}/ &&
|
|
-d $dir.'/'.$_
|
|
}
|
|
readdir( DIR );
|
|
closedir( DIR );
|
|
return @tmpList;
|
|
}
|
|
return ();
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod searchInWebContent($searchString, $web, \@topics, \%options ) -> \%map
|
|
|
|
Search for a string in the content of a web. The search must be over all
|
|
content and all formatted meta-data, though the latter search type is
|
|
deprecated (use searchMetaData instead).
|
|
|
|
* =$searchString= - the search string, in egrep format if regex
|
|
* =$web= - The web to search in
|
|
* =\@topics= - reference to a list of topics to search
|
|
* =\%options= - reference to an options hash
|
|
The =\%options= hash may contain the following options:
|
|
* =type= - if =regex= will perform a egrep-syntax RE search (default '')
|
|
* =casesensitive= - false to ignore case (defaulkt true)
|
|
* =files_without_match= - true to return files only (default false)
|
|
|
|
The return value is a reference to a hash which maps each matching topic
|
|
name to a list of the lines in that topic that matched the search,
|
|
as would be returned by 'grep'. If =files_without_match= is specified, it will
|
|
return on the first match in each topic (i.e. it will return only one
|
|
match per topic, and will not return matching lines).
|
|
|
|
=cut
|
|
|
|
sub searchInWebContent {
|
|
my( $this, $searchString, $topics, $options ) = @_;
|
|
ASSERT(defined $options) if DEBUG;
|
|
my $type = $options->{type} || '';
|
|
|
|
# I18N: 'grep' must use locales if needed,
|
|
# for case-insensitive searching. See TWiki::setupLocale.
|
|
my $program = '';
|
|
# FIXME: For Cygwin grep, do something about -E and -F switches
|
|
# - best to strip off any switches after first space in
|
|
# EgrepCmd etc and apply those as argument 1.
|
|
if( $type eq 'regex' ) {
|
|
$program = $TWiki::cfg{RCS}{EgrepCmd};
|
|
} else {
|
|
$program = $TWiki::cfg{RCS}{FgrepCmd};
|
|
}
|
|
|
|
$program =~ s/%CS{(.*?)\|(.*?)}%/$options->{casesensitive}?$1:$2/ge;
|
|
$program =~ s/%DET{(.*?)\|(.*?)}%/$options->{files_without_match}?$2:$1/ge;
|
|
|
|
my $sDir = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/';
|
|
my $seen = {};
|
|
# process topics in sets, fix for Codev.ArgumentListIsTooLongForSearch
|
|
my $maxTopicsInSet = 512; # max number of topics for a grep call
|
|
my @take = @$topics;
|
|
my @set = splice( @take, 0, $maxTopicsInSet );
|
|
my $sandbox = $this->{session}->{sandbox};
|
|
while( @set ) {
|
|
@set = map { "$sDir/$_.txt" } @set;
|
|
my ($matches, $exit ) = $sandbox->sysCommand(
|
|
$program,
|
|
TOKEN => $searchString,
|
|
FILES => \@set);
|
|
foreach my $match ( split( /\r?\n/, $matches )) {
|
|
if( $match =~ m/([^\/]*)\.txt(:(.*))?$/ ) {
|
|
push( @{$seen->{$1}}, $3 );
|
|
}
|
|
}
|
|
@set = splice( @take, 0, $maxTopicsInSet );
|
|
}
|
|
return $seen;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod moveWeb( $newWeb )
|
|
|
|
Move a web.
|
|
|
|
=cut
|
|
|
|
sub moveWeb {
|
|
my( $this, $newWeb ) = @_;
|
|
_moveFile( $TWiki::cfg{DataDir}.'/'.$this->{web},
|
|
$TWiki::cfg{DataDir}.'/'.$newWeb );
|
|
if( -d $TWiki::cfg{PubDir}.'/'.$this->{web} ) {
|
|
_moveFile( $TWiki::cfg{PubDir}.'/'.$this->{web},
|
|
$TWiki::cfg{PubDir}.'/'.$newWeb );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getRevision($version) -> $text
|
|
|
|
* =$version= if 0 or undef, or out of range (version number > number of revs) will return the latest revision.
|
|
|
|
Get the text of the given revision.
|
|
|
|
Designed to be overridden by subclasses, which can call up to this method
|
|
if the main file revision is required.
|
|
|
|
=cut
|
|
|
|
sub getRevision {
|
|
my( $this ) = @_;
|
|
return $this->_readFile( $this->{file} );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod storedDataExists() -> $boolean
|
|
|
|
Establishes if there is stored data associated with this handler.
|
|
|
|
=cut
|
|
|
|
sub storedDataExists {
|
|
my $this = shift;
|
|
return -e $this->{file};
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getTimestamp() -> $integer
|
|
|
|
Get the timestamp of the file
|
|
Returns 0 if no file, otherwise epoch seconds
|
|
|
|
=cut
|
|
|
|
sub getTimestamp {
|
|
my( $this ) = @_;
|
|
my $date = 0;
|
|
if( -e $this->{file} ) {
|
|
# SMELL: Why big number if fail?
|
|
$date = (stat $this->{file})[9] || 600000000;
|
|
}
|
|
return $date;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod restoreLatestRevision($wikiname)
|
|
|
|
Restore the plaintext file from the revision at the head.
|
|
|
|
=cut
|
|
|
|
sub restoreLatestRevision {
|
|
my( $this, $user ) = @_;
|
|
|
|
my $rev = $this->numRevisions();
|
|
my $text = $this->getRevision( $rev );
|
|
|
|
# If there is no ,v, create it
|
|
unless( -e $this->{rcsFile} ) {
|
|
$this->addRevisionFromText( $text, "restored", $user, time() );
|
|
} else {
|
|
$this->_saveFile( $this->{file}, $text );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod removeWeb( $web )
|
|
|
|
* =$web= - web being removed
|
|
|
|
Destroy a web, utterly. Removed the data and attachments in the web.
|
|
|
|
Use with great care! No backup is taken!
|
|
|
|
=cut
|
|
|
|
sub removeWeb {
|
|
my $this = shift;
|
|
|
|
# Just make sure of the context
|
|
ASSERT(!$this->{topic}) if DEBUG;
|
|
|
|
_rmtree( $TWiki::cfg{DataDir}.'/'.$this->{web} );
|
|
_rmtree( $TWiki::cfg{PubDir}.'/'.$this->{web} );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod moveTopic( $newWeb, $newTopic )
|
|
|
|
Move/rename a topic.
|
|
|
|
=cut
|
|
|
|
sub moveTopic {
|
|
my( $this, $newWeb, $newTopic ) = @_;
|
|
|
|
my $oldWeb = $this->{web};
|
|
my $oldTopic = $this->{topic};
|
|
|
|
# Move data file
|
|
my $new = new TWiki::Store::RcsFile( $this->{session},
|
|
$newWeb, $newTopic, '' );
|
|
_moveFile( $this->{file}, $new->{file} );
|
|
|
|
# Move history
|
|
_mkPathTo( $new->{rcsFile});
|
|
if( -e $this->{rcsFile} ) {
|
|
_moveFile( $this->{rcsFile}, $new->{rcsFile} );
|
|
}
|
|
|
|
# Move attachments
|
|
my $from = $TWiki::cfg{PubDir}.'/'.$this->{web}.'/'.$this->{topic};
|
|
if( -e $from ) {
|
|
my $to = $TWiki::cfg{PubDir}.'/'.$newWeb.'/'.$newTopic;
|
|
_moveFile( $from, $to );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod copyTopic( $newWeb, $newTopic )
|
|
|
|
Copy a topic.
|
|
|
|
=cut
|
|
|
|
sub copyTopic {
|
|
my( $this, $newWeb, $newTopic ) = @_;
|
|
|
|
my $oldWeb = $this->{web};
|
|
my $oldTopic = $this->{topic};
|
|
|
|
my $new = new TWiki::Store::RcsFile( $this->{session},
|
|
$newWeb, $newTopic, '' );
|
|
|
|
_copyFile( $this->{file}, $new->{file} );
|
|
if( -e $this->{rcsFile} ) {
|
|
_copyFile( $this->{rcsFile}, $new->{rcsFile} );
|
|
}
|
|
|
|
if( opendir(DIR, $TWiki::cfg{PubDir}.'/'.$this->{web}.'/'.
|
|
$this->{topic} )) {
|
|
for my $att ( grep { !/^\./ } readdir DIR ) {
|
|
$att = TWiki::Sandbox::untaintUnchecked( $att );
|
|
my $oldAtt = new TWiki::Store::RcsFile(
|
|
$this->{session}, $this->{web}, $this->{topic}, $att );
|
|
$oldAtt->copyAttachment( $newWeb, $newTopic );
|
|
}
|
|
|
|
closedir DIR;
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod moveAttachment( $newWeb, $newTopic, $newAttachment )
|
|
|
|
Move an attachment from one topic to another. The name is retained.
|
|
|
|
=cut
|
|
|
|
sub moveAttachment {
|
|
my( $this, $newWeb, $newTopic, $newAttachment ) = @_;
|
|
|
|
# FIXME might want to delete old directories if empty
|
|
my $new = TWiki::Store::RcsFile->new( $this->{session}, $newWeb,
|
|
$newTopic, $newAttachment );
|
|
|
|
_moveFile( $this->{file}, $new->{file} );
|
|
|
|
if( -e $this->{rcsFile} ) {
|
|
_moveFile( $this->{rcsFile}, $new->{rcsFile} );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod copyAttachment( $newWeb, $newTopic )
|
|
|
|
Copy an attachment from one topic to another. The name is retained.
|
|
|
|
=cut
|
|
|
|
sub copyAttachment {
|
|
my( $this, $newWeb, $newTopic ) = @_;
|
|
|
|
my $oldWeb = $this->{web};
|
|
my $oldTopic = $this->{topic};
|
|
my $attachment = $this->{attachment};
|
|
|
|
my $new = TWiki::Store::RcsFile->new( $this->{session}, $newWeb,
|
|
$newTopic, $attachment );
|
|
|
|
_copyFile( $this->{file}, $new->{file} );
|
|
|
|
if( -e $this->{rcsFile} ) {
|
|
_copyFile( $this->{rcsFile}, $new->{rcsFile} );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod isAsciiDefault ( ) -> $boolean
|
|
|
|
Check if this file type is known to be an ascii type file.
|
|
|
|
=cut
|
|
|
|
sub isAsciiDefault {
|
|
my $this = shift;
|
|
return ( $this->{attachment} =~
|
|
/$TWiki::cfg{RCS}{asciiFileSuffixes}/ );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod setLock($lock, $user)
|
|
|
|
Set a lock on the topic, if $lock, otherwise clear it.
|
|
$user is a wikiname.
|
|
|
|
SMELL: there is a tremendous amount of potential for race
|
|
conditions using this locking approach.
|
|
|
|
=cut
|
|
|
|
sub setLock {
|
|
my( $this, $lock, $user ) = @_;
|
|
|
|
$user = $this->{session}->{user} unless $user;
|
|
|
|
my $filename = $this->_controlFileName('lock');
|
|
if( $lock ) {
|
|
my $lockTime = time();
|
|
$this->_saveFile( $filename, $user."\n".$lockTime );
|
|
} else {
|
|
unlink $filename ||
|
|
throw Error::Simple( 'RCS: failed to delete '.$filename.': '.$! );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod isLocked( ) -> ($user, $time)
|
|
|
|
See if a twiki lock exists. Return the lock user and lock time if it does.
|
|
|
|
=cut
|
|
|
|
sub isLocked {
|
|
my( $this ) = @_;
|
|
|
|
my $filename = $this->_controlFileName('lock');
|
|
if ( -e $filename ) {
|
|
my $t = $this->_readFile( $filename );
|
|
return split( /\s+/, $t, 2 );
|
|
}
|
|
return ( undef, undef );
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod setLease( $lease )
|
|
|
|
* =$lease= reference to lease hash, or undef if the existing lease is to be cleared.
|
|
|
|
Set an lease on the topic.
|
|
|
|
=cut
|
|
|
|
sub setLease {
|
|
my( $this, $lease ) = @_;
|
|
|
|
my $filename = $this->_controlFileName('lease');
|
|
if( $lease ) {
|
|
$this->_saveFile( $filename, join( "\n", %$lease ) );
|
|
} elsif( -e $filename ) {
|
|
unlink $filename ||
|
|
throw Error::Simple( 'RCS: failed to delete '.$filename.': '.$! );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getLease() -> $lease
|
|
|
|
Get the current lease on the topic.
|
|
|
|
=cut
|
|
|
|
sub getLease {
|
|
my( $this ) = @_;
|
|
|
|
my $filename = $this->_controlFileName('lease');
|
|
if ( -e $filename ) {
|
|
my $t = $this->_readFile( $filename );
|
|
my $lease = { split( /\r?\n/, $t ) };
|
|
return $lease;
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod removeSpuriousLeases( $web )
|
|
|
|
Remove leases that are not related to a topic. These can get left behind in
|
|
some store implementations when a topic is created, but never saved.
|
|
|
|
=cut
|
|
|
|
sub removeSpuriousLeases {
|
|
my( $this ) = @_;
|
|
my $web = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/';
|
|
if (opendir(W, $web)) {
|
|
foreach my $f (readdir(W)) {
|
|
if ($f =~ /^(.*)\.lease$/) {
|
|
if (! -e "$1.txt,v") {
|
|
unlink($f);
|
|
}
|
|
}
|
|
}
|
|
closedir(W);
|
|
}
|
|
}
|
|
|
|
sub _saveStream {
|
|
my( $this, $fh ) = @_;
|
|
|
|
ASSERT($fh) if DEBUG;
|
|
|
|
_mkPathTo( $this->{file} );
|
|
open( F, '>'.$this->{file} ) ||
|
|
throw Error::Simple( 'RCS: open '.$this->{file}.' failed: '.$! );
|
|
binmode( F ) ||
|
|
throw Error::Simple( 'RCS: failed to binmode '.$this->{file}.': '.$! );
|
|
my $text;
|
|
binmode(F);
|
|
while( read( $fh, $text, 1024 )) {
|
|
print F $text;
|
|
}
|
|
close(F) ||
|
|
throw Error::Simple( 'RCS: close '.$this->{file}.' failed: '.$! );;
|
|
|
|
chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
|
|
|
|
return '';
|
|
}
|
|
|
|
sub _copyFile {
|
|
my( $from, $to ) = @_;
|
|
|
|
_mkPathTo( $to );
|
|
unless( File::Copy::copy( $from, $to ) ) {
|
|
throw Error::Simple( 'RCS: copy '.$from.' to '.$to.' failed: '.$! );
|
|
}
|
|
}
|
|
|
|
sub _moveFile {
|
|
my( $from, $to ) = @_;
|
|
|
|
_mkPathTo( $to );
|
|
unless( File::Copy::move( $from, $to ) ) {
|
|
throw Error::Simple( 'RCS: move '.$from.' to '.$to.' failed: '.$! );
|
|
}
|
|
}
|
|
|
|
sub _saveFile {
|
|
my( $this, $name, $text ) = @_;
|
|
|
|
_mkPathTo( $name );
|
|
|
|
open( FILE, '>'.$name ) ||
|
|
throw Error::Simple( 'RCS: failed to create file '.$name.': '.$! );
|
|
binmode( FILE ) ||
|
|
throw Error::Simple( 'RCS: failed to binmode '.$name.': '.$! );
|
|
print FILE $text;
|
|
close( FILE) ||
|
|
throw Error::Simple( 'RCS: failed to create file '.$name.': '.$! );
|
|
|
|
return undef;
|
|
}
|
|
|
|
sub _readFile {
|
|
my( $this, $name ) = @_;
|
|
my $data;
|
|
if( open( IN_FILE, '<', $name )) {
|
|
binmode( IN_FILE );
|
|
local $/ = undef;
|
|
$data = <IN_FILE>;
|
|
close( IN_FILE );
|
|
}
|
|
$data ||= '';
|
|
return $data;
|
|
}
|
|
|
|
sub _mkTmpFilename {
|
|
my $tmpdir = File::Spec->tmpdir();
|
|
my $file = _mktemp( 'twikiAttachmentXXXXXX', $tmpdir );
|
|
return File::Spec->catfile($tmpdir, $file);
|
|
}
|
|
|
|
# Adapted from CPAN - File::MkTemp
|
|
sub _mktemp {
|
|
my ($template,$dir,$ext,$keepgen,$lookup);
|
|
my (@template,@letters);
|
|
|
|
ASSERT(@_ == 1 || @_ == 2 || @_ == 3) if DEBUG;
|
|
|
|
($template,$dir,$ext) = @_;
|
|
@template = split //, $template;
|
|
|
|
ASSERT($template =~ /XXXXXX$/) if DEBUG;
|
|
|
|
if ($dir){
|
|
ASSERT(-e $dir) if DEBUG;
|
|
}
|
|
|
|
@letters =
|
|
split(//,'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ');
|
|
|
|
$keepgen = 1;
|
|
|
|
while ($keepgen){
|
|
for (my $i = $#template; $i >= 0 && ($template[$i] eq 'X'); $i--){
|
|
$template[$i] = $letters[int(rand 52)];
|
|
}
|
|
|
|
undef $template;
|
|
|
|
$template = pack 'a' x @template, @template;
|
|
|
|
$template = $template . $ext if ($ext);
|
|
|
|
if ($dir){
|
|
$lookup = File::Spec->catfile($dir, $template);
|
|
$keepgen = 0 unless (-e $lookup);
|
|
} else {
|
|
$keepgen = 0;
|
|
}
|
|
|
|
next if $keepgen == 0;
|
|
}
|
|
|
|
return($template);
|
|
}
|
|
|
|
# remove a directory and all subdirectories.
|
|
sub _rmtree {
|
|
my $root = shift;
|
|
|
|
if( opendir( D, $root ) ) {
|
|
foreach my $entry ( grep { !/^\.+$/ } readdir( D ) ) {
|
|
$entry =~ /^(.*)$/;
|
|
$entry = $root.'/'.$1;
|
|
if( -d $entry ) {
|
|
_rmtree( $entry );
|
|
} else {
|
|
unless( unlink( $entry ) ) {
|
|
throw Error::Simple( 'RCS: Failed to delete file '.
|
|
$entry.': '.$! );
|
|
}
|
|
}
|
|
}
|
|
closedir(D);
|
|
|
|
rmdir( $root ) ||
|
|
throw Error::Simple( 'RCS: Failed to delete '.$root.': '.$! );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getStream() -> \*STREAM
|
|
|
|
Return a text stream that will supply the text stored in the topic.
|
|
|
|
=cut
|
|
|
|
sub getStream {
|
|
my( $this ) = shift;
|
|
my $strm;
|
|
unless( open( $strm, '<'.$this->{file} )) {
|
|
throw Error::Simple( 'RCS: stream open '.$this->{file}.
|
|
' failed: '.$! );
|
|
}
|
|
return $strm;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod numRevisions() -> $integer
|
|
|
|
Must be provided by subclasses.
|
|
|
|
Find out how many revisions there are. If there is a problem, such
|
|
as a nonexistent file, returns 0.
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod initBinary()
|
|
|
|
Initialise a binary file.
|
|
|
|
Must be provided by subclasses.
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod initText()
|
|
|
|
Initialise a text file.
|
|
|
|
Must be provided by subclasses.
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod addRevisionFromText($text, $comment, $user, $date)
|
|
|
|
Add new revision. Replace file with text.
|
|
* =$text= of new revision
|
|
* =$comment= checkin comment
|
|
* =$user= is a wikiname.
|
|
* =$date= in epoch seconds; may be ignored
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod addRevisionFromStream($fh, $comment, $user, $date)
|
|
|
|
Add new revision. Replace file with contents of stream.
|
|
* =$fh= filehandle for contents of new revision
|
|
* =$comment= checkin comment
|
|
* =$user= is a wikiname.
|
|
* =$date= in epoch seconds; may be ignored
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod replaceRevision($text, $comment, $user, $date)
|
|
|
|
Replace the top revision.
|
|
* =$text= is the new revision
|
|
* =$date= is in epoch seconds.
|
|
* =$user= is a wikiname.
|
|
* =$comment= is a string
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod deleteRevision()
|
|
|
|
Delete the last revision - do nothing if there is only one revision
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut to implementation
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod revisionDiff ( $rev1, $rev2, $contextLines ) -> \@diffArray
|
|
|
|
rev2 newer than rev1.
|
|
Return reference to an array of [ diffType, $right, $left ]
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getRevision($version) -> $text
|
|
|
|
Get the text for a given revision. The version number must be an integer.
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getRevisionAtTime($time) -> $rev
|
|
|
|
Get a single-digit version number for the rev that was alive at the
|
|
given epoch-secs time, or undef it none could be found.
|
|
|
|
*Virtual method* - must be implemented by subclasses
|
|
|
|
=cut
|
|
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getAttachmentAttributes($web, $topic, $attachment)
|
|
|
|
returns [stat] for any given web, topic, $attachment
|
|
SMELL - should this return a hash of arbitrary attributes so that
|
|
SMELL + attributes supported by the underlying filesystem are supported
|
|
SMELL + (eg: windows directories supporting photo "author", "dimension" fields)
|
|
|
|
=cut
|
|
|
|
sub getAttachmentAttributes {
|
|
my( $this, $web, $topic, $attachment ) = @_;
|
|
ASSERT(defined $attachment) if DEBUG;
|
|
|
|
my $dir = dirForTopicAttachments($web, $topic);
|
|
my @stat = stat ($dir."/".$attachment);
|
|
|
|
return @stat;
|
|
}
|
|
|
|
=pod
|
|
|
|
sub _constructAttributesForAutoAttached
|
|
as long as stat is defined, return an emulated set of attributes for that attachment.
|
|
|
|
=cut
|
|
|
|
sub _constructAttributesForAutoAttached {
|
|
my ($file, $stat) = @_;
|
|
|
|
my %pairs = (
|
|
name => $file,
|
|
version => '',
|
|
path => $file,
|
|
size => $stat->[7],
|
|
date => $stat->[9],
|
|
user => 'UnknownUser',
|
|
comment => '',
|
|
attr => '',
|
|
autoattached => '1'
|
|
);
|
|
|
|
if ($#$stat > 0) {
|
|
return \%pairs;
|
|
} else {
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod getAttachmentList($web, $topic)
|
|
|
|
returns {} of filename => { key => value, key2 => value } for any given web, topic
|
|
Ignores files starting with _ or ending with ,v
|
|
|
|
=cut
|
|
|
|
sub getAttachmentList {
|
|
my( $this, $web, $topic ) = @_;
|
|
my $dir = dirForTopicAttachments($web, $topic);
|
|
|
|
opendir DIR, $dir || return '';
|
|
my %attachmentList = ();
|
|
my @files = sort grep { m/^[^\.*_]/ } readdir( DIR );
|
|
@files = grep { !/.*,v/ } @files;
|
|
foreach my $attachment ( @files ) {
|
|
my @stat = stat ($dir."/".$attachment);
|
|
$attachmentList{$attachment} = _constructAttributesForAutoAttached($attachment, \@stat);
|
|
}
|
|
closedir( DIR );
|
|
return %attachmentList;
|
|
}
|
|
|
|
sub dirForTopicAttachments {
|
|
my ($web, $topic ) = @_;
|
|
return $TWiki::cfg{PubDir}.'/'.$web.'/'.$topic;
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ ObjectMethod stringify()
|
|
|
|
Generate string representation for debugging
|
|
|
|
=cut
|
|
|
|
sub stringify {
|
|
my $this = shift;
|
|
|
|
return $this->{web}.'.'.
|
|
($this->{topic} || '{no topic}').
|
|
($this->{attachment} ? ':'.$this->{attachment} : '').
|
|
$this->{file}.(-e $this->{file} ? '(e)' : '').
|
|
'/'.$this->{rcsFile}.(-e $this->{rcsFile} ? '(e)' : '');
|
|
}
|
|
|
|
# Chop out recognisable path components to prevent hacking based on error
|
|
# messages
|
|
sub _hidePath {
|
|
my ( $this, $erf ) = @_;
|
|
$erf =~ s#.*(/\w+/\w+\.[\w,]*)$#...$1#;
|
|
return $erf;
|
|
}
|
|
|
|
1;
|