lib/TWiki/Store/RcsFile.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
permissions -rw-r--r--
RELEASE 4.2.0 freetown
     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-2007 Peter Thoeny, peter@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 2
    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::RcsFile
    24 
    25 This class is PACKAGE PRIVATE to Store, and should never be
    26 used from anywhere else. It is the base class of implementations of stores
    27 that manipulate RCS format files.
    28 
    29 The general contract of the methods on this class and its subclasses
    30 calls for errors to be signalled by Error::Simple exceptions.
    31 
    32 Refer to Store.pm for models of usage.
    33 
    34 =cut
    35 
    36 package TWiki::Store::RcsFile;
    37 
    38 use strict;
    39 use Assert;
    40 
    41 require File::Copy;
    42 require File::Spec;
    43 require File::Path;
    44 require File::Basename;
    45 
    46 require TWiki::Store;
    47 require TWiki::Sandbox;
    48 
    49 =pod
    50 
    51 ---++ ClassMethod new($session, $web, $topic, $attachment)
    52 
    53 Constructor. There is one object per stored file.
    54 
    55 Note that $web, $topic and $attachment must be untainted!
    56 
    57 =cut
    58 
    59 sub new {
    60     my( $class, $session, $web, $topic, $attachment ) = @_;
    61     my $this = bless( { session => $session }, $class );
    62 
    63     $this->{web} = $web;
    64 
    65     if( $topic ) {
    66         my $rcsSubDir = ( $TWiki::cfg{RCS}{useSubDir} ? '/RCS' : '' );
    67 
    68         $this->{topic} = $topic;
    69 
    70         if( $attachment ) {
    71             $this->{attachment} = $attachment;
    72 
    73             $this->{file} = $TWiki::cfg{PubDir}.'/'.$web.'/'.
    74               $this->{topic}.'/'.$attachment;
    75             $this->{rcsFile} = $TWiki::cfg{PubDir}.'/'.
    76               $web.'/'.$topic.$rcsSubDir.'/'.$attachment.',v';
    77 
    78         } else {
    79             $this->{file} = $TWiki::cfg{DataDir}.'/'.$web.'/'.
    80               $topic.'.txt';
    81             $this->{rcsFile} = $TWiki::cfg{DataDir}.'/'.
    82               $web.$rcsSubDir.'/'.$topic.'.txt,v';
    83         }
    84     }
    85 
    86     # Default to remembering changes for a month
    87     $TWiki::cfg{Store}{RememberChangesFor} ||= 31 * 24 * 60 * 60;
    88 
    89     return $this;
    90 }
    91 
    92 =begin twiki
    93 
    94 ---++ ObjectMethod finish()
    95 Break circular references.
    96 
    97 =cut
    98 
    99 # Note to developers; please undef *all* fields in the object explicitly,
   100 # whether they are references or not. That way this method is "golden
   101 # documentation" of the live fields in the object.
   102 sub finish {
   103     my $this = shift;
   104     undef $this->{file};
   105     undef $this->{rcsFile};
   106     undef $this->{web};
   107     undef $this->{topic};
   108     undef $this->{attachment};
   109     undef $this->{searchFn};
   110     undef $this->{session};
   111 }
   112 
   113 # Used in subclasses for late initialisation during object creation
   114 # (after the object is blessed into the subclass)
   115 sub init {
   116     my $this = shift;
   117 
   118     return unless $this->{topic};
   119 
   120     unless( -e $this->{file} ) {
   121         if( $this->{attachment} && !$this->isAsciiDefault() ) {
   122             $this->initBinary();
   123         } else {
   124             $this->initText();
   125         }
   126     }
   127 }
   128 
   129 # Make any missing paths on the way to this file
   130 # SMELL: duplicates CPAN File::Tree::mkpath
   131 sub mkPathTo {
   132 
   133     my $file = shift;
   134 
   135     $file = TWiki::Sandbox::untaintUnchecked( $file ); 
   136     my $path = File::Basename::dirname($file);
   137     eval {
   138         File::Path::mkpath($path, 0, $TWiki::cfg{RCS}{dirPermission});
   139     };
   140     if ($@) {
   141        throw Error::Simple("RCS: failed to create ${path}: $!");
   142     }
   143 }
   144 
   145 # SMELL: this should use TWiki::Time
   146 sub _epochToRcsDateTime {
   147     my( $dateTime ) = @_;
   148     # TODO: should this be gmtime or local time?
   149     my( $sec,$min,$hour,$mday,$mon,$year,$wday,$yday ) = gmtime( $dateTime );
   150     $year += 1900 if( $year > 99 );
   151     my $rcsDateTime = sprintf '%d.%02d.%02d.%02d.%02d.%02d',
   152       ( $year, $mon + 1, $mday, $hour, $min, $sec );
   153     return $rcsDateTime;
   154 }
   155 
   156 # filenames for lock and lease files
   157 sub _controlFileName {
   158     my( $this, $type ) = @_;
   159 
   160     my $fn = $this->{file} || '';
   161     $fn =~ s/txt$/$type/;
   162     return $fn;
   163 }
   164 
   165 =pod
   166 
   167 ---++ ObjectMethod getRevisionInfo($version) -> ($rev, $date, $user, $comment)
   168 
   169    * =$version= if 0 or undef, or out of range (version number > number of revs) will return info about the latest revision.
   170 
   171 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.
   172 
   173 Designed to be overridden by subclasses, which can call up to this method
   174 if file-based rev info is required.
   175 
   176 =cut
   177 
   178 sub getRevisionInfo {
   179     my( $this ) = @_;
   180     my $fileDate = $this->getTimestamp();
   181     return ( 1, $fileDate, $this->{session}->{users}->getCanonicalUserID($TWiki::cfg{DefaultUserLogin}),
   182              'Default revision information' );
   183 }
   184 
   185 =pod
   186 
   187 ---++ ObjectMethod getLatestRevision() -> $text
   188 
   189 Get the text of the most recent revision
   190 
   191 =cut
   192 
   193 sub getLatestRevision {
   194     my $this = shift;
   195     return readFile( $this, $this->{file} );
   196 }
   197 
   198 =pod
   199 
   200 ---++ ObjectMethod getLatestRevisionTime() -> $text
   201 
   202 Get the time of the most recent revision
   203 
   204 =cut
   205 
   206 sub getLatestRevisionTime {
   207     my @e = stat( shift->{file} );
   208     return $e[9] || 0;
   209 }
   210 
   211 =pod
   212 
   213 ---+++ ObjectMethod getWorkArea( $key ) -> $directorypath
   214 
   215 Gets a private directory uniquely identified by $key. The directory is
   216 intended as a work area for plugins.
   217 
   218 The standard is a directory named the same as "key" under
   219 $TWiki::cfg{WorkingDir}/work_areas
   220 
   221 =cut
   222 
   223 sub getWorkArea {
   224     my( $this, $key ) = @_;
   225 
   226     # untaint and detect nasties
   227     $key = TWiki::Sandbox::normalizeFileName( $key );
   228     throw Error::Simple( "Bad work area name $key" ) unless ( $key );
   229 
   230     my $dir =  "$TWiki::cfg{WorkingDir}/work_areas/$key";
   231 
   232     unless( -d $dir ) {
   233         mkdir( $dir ) || throw Error::Simple(<<ERROR);
   234 Failed to create $key work area. Check your setting of {RCS}{WorkAreaDir}
   235 in =configure=.
   236 ERROR
   237     }
   238     return $dir;
   239 }
   240 
   241 =pod
   242 
   243 ---++ ObjectMethod getTopicNames() -> @topics
   244 
   245 Get list of all topics in a web
   246    * =$web= - Web name, required, e.g. ='Sandbox'=
   247 Return a topic list, e.g. =( 'WebChanges',  'WebHome', 'WebIndex', 'WebNotify' )=
   248 
   249 =cut
   250 
   251 sub getTopicNames {
   252     my $this = shift;
   253 
   254     opendir DIR, $TWiki::cfg{DataDir}.'/'.$this->{web};
   255     # the name filter is used to ensure we don't return filenames
   256     # that contain illegal characters as topic names.
   257     my @topicList =
   258       sort
   259         map { TWiki::Sandbox::untaintUnchecked( $_ ) }
   260           grep { !/$TWiki::cfg{NameFilter}/ && s/\.txt$// }
   261             readdir( DIR );
   262     closedir( DIR );
   263     return @topicList;
   264 }
   265 
   266 =pod
   267 
   268 ---++ ObjectMethod getWebNames() -> @webs
   269 
   270 Gets a list of names of subwebs in the current web
   271 
   272 =cut
   273 
   274 sub getWebNames {
   275     my $this = shift;
   276     my $dir = $TWiki::cfg{DataDir}.'/'.$this->{web};
   277     if( opendir( DIR, $dir ) ) {
   278         my @tmpList =
   279           sort
   280             map { TWiki::Sandbox::untaintUnchecked( $_ ) }
   281               grep { !/\./ &&
   282                      !/$TWiki::cfg{NameFilter}/ &&
   283                      -d $dir.'/'.$_
   284                    }
   285                 readdir( DIR );
   286         closedir( DIR );
   287         return @tmpList;
   288     }
   289     return ();
   290 }
   291 
   292 =pod
   293 
   294 ---++ ObjectMethod searchInWebContent($searchString, $web, \@topics, \%options ) -> \%map
   295 
   296 Search for a string in the content of a web. The search must be over all
   297 content and all formatted meta-data, though the latter search type is
   298 deprecated (use searchMetaData instead).
   299 
   300    * =$searchString= - the search string, in egrep format if regex
   301    * =$web= - The web to search in
   302    * =\@topics= - reference to a list of topics to search
   303    * =\%options= - reference to an options hash
   304 The =\%options= hash may contain the following options:
   305    * =type= - if =regex= will perform a egrep-syntax RE search (default '')
   306    * =casesensitive= - false to ignore case (defaulkt true)
   307    * =files_without_match= - true to return files only (default false)
   308 
   309 The return value is a reference to a hash which maps each matching topic
   310 name to a list of the lines in that topic that matched the search,
   311 as would be returned by 'grep'. If =files_without_match= is specified, it will
   312 return on the first match in each topic (i.e. it will return only one
   313 match per topic, and will not return matching lines).
   314 
   315 =cut
   316 
   317 sub searchInWebContent {
   318     my( $this, $searchString, $topics, $options ) = @_;
   319     ASSERT(defined $options) if DEBUG;
   320     my $sDir = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/';
   321 
   322     unless ($this->{searchFn}) {
   323         eval "require $TWiki::cfg{RCS}{SearchAlgorithm}";
   324         die "Bad {RCS}{SearchAlgorithm}; suggest you run configure and select a different algorithm\n$@" if $@;
   325         $this->{searchFn} = $TWiki::cfg{RCS}{SearchAlgorithm}.'::search';
   326     }
   327 
   328     no strict 'refs';
   329     return &{$this->{searchFn}}($searchString, $topics, $options,
   330                $sDir, $TWiki::sandbox);
   331     use strict 'refs';
   332 }
   333 
   334 =pod
   335 
   336 ---++ ObjectMethod searchInWebMetaData($query, \@topics) -> \%matches
   337 
   338 Search for a meta-data expression in the content of a web. =$query= must be a =TWiki::Query= object.
   339 
   340 Returns a reference to a hash that maps the names of topics that all matched
   341 to the result of the query expression (e.g. if the query expression is
   342 'TOPICPARENT.name' then you will get back a hash that maps topic names
   343 to their parent.
   344 
   345 SMELL: this is *really* inefficient!
   346 
   347 =cut
   348 
   349 sub searchInWebMetaData {
   350     my( $this, $query, $topics ) = @_;
   351 
   352     my $store = $this->{session}->{store};
   353 
   354     unless ($this->{queryFn}) {
   355         eval "require $TWiki::cfg{RCS}{QueryAlgorithm}";
   356         die "Bad {RCS}{QueryAlgorithm}; suggest you run configure and select a different algorithm\n$@" if $@;
   357         $this->{queryFn} = $TWiki::cfg{RCS}{QueryAlgorithm}.'::query';
   358     }
   359 
   360     no strict 'refs';
   361     return &{$this->{queryFn}}($query, $this->{web}, $topics, $store);
   362     use strict 'refs';
   363 }
   364 
   365 =pod
   366 
   367 ---++ ObjectMethod moveWeb(  $newWeb )
   368 
   369 Move a web.
   370 
   371 =cut
   372 
   373 sub moveWeb {
   374     my( $this, $newWeb ) = @_;
   375     _moveFile( $TWiki::cfg{DataDir}.'/'.$this->{web},
   376                $TWiki::cfg{DataDir}.'/'.$newWeb );
   377     if( -d $TWiki::cfg{PubDir}.'/'.$this->{web} ) {
   378         _moveFile( $TWiki::cfg{PubDir}.'/'.$this->{web},
   379                    $TWiki::cfg{PubDir}.'/'.$newWeb );
   380     }
   381 }
   382 
   383 =pod
   384 
   385 ---++ ObjectMethod getRevision($version) -> $text
   386 
   387    * =$version= if 0 or undef, or out of range (version number > number of revs) will return the latest revision.
   388 
   389 Get the text of the given revision.
   390 
   391 Designed to be overridden by subclasses, which can call up to this method
   392 if the main file revision is required.
   393 
   394 =cut
   395 
   396 sub getRevision {
   397     my( $this ) = @_;
   398     return readFile( $this, $this->{file} );
   399 }
   400 
   401 =pod
   402 
   403 ---++ ObjectMethod storedDataExists() -> $boolean
   404 
   405 Establishes if there is stored data associated with this handler.
   406 
   407 =cut
   408 
   409 sub storedDataExists {
   410     my $this = shift;
   411     return -e $this->{file};
   412 }
   413 
   414 =pod
   415 
   416 ---++ ObjectMethod getTimestamp() -> $integer
   417 
   418 Get the timestamp of the file
   419 Returns 0 if no file, otherwise epoch seconds
   420 
   421 =cut
   422 
   423 sub getTimestamp {
   424     my( $this ) = @_;
   425     my $date = 0;
   426     if( -e $this->{file} ) {
   427         # SMELL: Why big number if fail?
   428         $date = (stat $this->{file})[9] || 600000000;
   429     }
   430     return $date;
   431 }
   432 
   433 =pod
   434 
   435 ---++ ObjectMethod restoreLatestRevision( $user )
   436 
   437 Restore the plaintext file from the revision at the head.
   438 
   439 =cut
   440 
   441 sub restoreLatestRevision {
   442     my( $this, $user ) = @_;
   443 
   444     my $rev = $this->numRevisions();
   445     my $text = $this->getRevision( $rev );
   446 
   447     # If there is no ,v, create it
   448     unless( -e $this->{rcsFile} ) {
   449         $this->addRevisionFromText( $text, "restored", $user, time() );
   450     } else {
   451         saveFile( $this, $this->{file}, $text );
   452     }
   453 }
   454 
   455 =pod
   456 
   457 ---++ ObjectMethod removeWeb( $web )
   458 
   459    * =$web= - web being removed
   460 
   461 Destroy a web, utterly. Removed the data and attachments in the web.
   462 
   463 Use with great care! No backup is taken!
   464 
   465 =cut
   466 
   467 sub removeWeb {
   468     my $this = shift;
   469 
   470     # Just make sure of the context
   471     ASSERT(!$this->{topic}) if DEBUG;
   472 
   473     _rmtree( $TWiki::cfg{DataDir}.'/'.$this->{web} );
   474     _rmtree( $TWiki::cfg{PubDir}.'/'.$this->{web} );
   475 }
   476 
   477 =pod
   478 
   479 ---++ ObjectMethod moveTopic( $newWeb, $newTopic )
   480 
   481 Move/rename a topic.
   482 
   483 =cut
   484 
   485 sub moveTopic {
   486     my( $this, $newWeb, $newTopic ) = @_;
   487 
   488     my $oldWeb = $this->{web};
   489     my $oldTopic = $this->{topic};
   490 
   491     # Move data file
   492     my $new = new TWiki::Store::RcsFile( $this->{session},
   493                                          $newWeb, $newTopic, '' );
   494     _moveFile( $this->{file}, $new->{file} );
   495 
   496     # Move history
   497     mkPathTo( $new->{rcsFile});
   498     if( -e $this->{rcsFile} ) {
   499         _moveFile( $this->{rcsFile}, $new->{rcsFile} );
   500     }
   501 
   502     # Move attachments
   503     my $from = $TWiki::cfg{PubDir}.'/'.$this->{web}.'/'.$this->{topic};
   504     if( -e $from ) {
   505         my $to = $TWiki::cfg{PubDir}.'/'.$newWeb.'/'.$newTopic;
   506         _moveFile( $from, $to );
   507     }
   508 }
   509 
   510 =pod
   511 
   512 ---++ ObjectMethod copyTopic( $newWeb, $newTopic )
   513 
   514 Copy a topic.
   515 
   516 =cut
   517 
   518 sub copyTopic {
   519     my( $this, $newWeb, $newTopic ) = @_;
   520 
   521     my $oldWeb = $this->{web};
   522     my $oldTopic = $this->{topic};
   523 
   524     my $new = new TWiki::Store::RcsFile( $this->{session},
   525                                          $newWeb, $newTopic, '' );
   526 
   527     _copyFile( $this->{file}, $new->{file} );
   528     if( -e $this->{rcsFile} ) {
   529         _copyFile( $this->{rcsFile}, $new->{rcsFile} );
   530     }
   531 
   532     if( opendir(DIR, $TWiki::cfg{PubDir}.'/'.$this->{web}.'/'.
   533                   $this->{topic} )) {
   534         for my $att ( grep { !/^\./ } readdir DIR ) {
   535             $att = TWiki::Sandbox::untaintUnchecked( $att );
   536             my $oldAtt = new TWiki::Store::RcsFile(
   537                 $this->{session}, $this->{web}, $this->{topic}, $att );
   538             $oldAtt->copyAttachment( $newWeb, $newTopic );
   539         }
   540 
   541         closedir DIR;
   542     }
   543 }
   544 
   545 =pod
   546 
   547 ---++ ObjectMethod moveAttachment( $newWeb, $newTopic, $newAttachment )
   548 
   549 Move an attachment from one topic to another. The name is retained.
   550 
   551 =cut
   552 
   553 sub moveAttachment {
   554     my( $this, $newWeb, $newTopic, $newAttachment ) = @_;
   555 
   556     # FIXME might want to delete old directories if empty
   557     my $new = TWiki::Store::RcsFile->new( $this->{session}, $newWeb,
   558                                           $newTopic, $newAttachment );
   559 
   560     _moveFile( $this->{file}, $new->{file} );
   561 
   562     if( -e $this->{rcsFile} ) {
   563         _moveFile( $this->{rcsFile}, $new->{rcsFile} );
   564     }
   565 }
   566 
   567 =pod
   568 
   569 ---++ ObjectMethod copyAttachment( $newWeb, $newTopic )
   570 
   571 Copy an attachment from one topic to another. The name is retained.
   572 
   573 =cut
   574 
   575 sub copyAttachment {
   576     my( $this, $newWeb, $newTopic ) = @_;
   577 
   578     my $oldWeb = $this->{web};
   579     my $oldTopic = $this->{topic};
   580     my $attachment = $this->{attachment};
   581 
   582     my $new = TWiki::Store::RcsFile->new( $this->{session}, $newWeb,
   583                                           $newTopic, $attachment );
   584 
   585     _copyFile( $this->{file}, $new->{file} );
   586 
   587     if( -e $this->{rcsFile} ) {
   588         _copyFile( $this->{rcsFile}, $new->{rcsFile} );
   589     }
   590 }
   591 
   592 =pod
   593 
   594 ---++ ObjectMethod isAsciiDefault (   ) -> $boolean
   595 
   596 Check if this file type is known to be an ascii type file.
   597 
   598 =cut
   599 
   600 sub isAsciiDefault {
   601     my $this = shift;
   602     return ( $this->{attachment} =~
   603                /$TWiki::cfg{RCS}{asciiFileSuffixes}/ );
   604 }
   605 
   606 =pod
   607 
   608 ---++ ObjectMethod setLock($lock, $user)
   609 
   610 Set a lock on the topic, if $lock, otherwise clear it.
   611 $user is a wikiname.
   612 
   613 SMELL: there is a tremendous amount of potential for race
   614 conditions using this locking approach.
   615 
   616 =cut
   617 
   618 sub setLock {
   619     my( $this, $lock, $user ) = @_;
   620 
   621     $user = $this->{session}->{user} unless $user;
   622 
   623     my $filename = _controlFileName( $this, 'lock');
   624     if( $lock ) {
   625         my $lockTime = time();
   626         saveFile( $this, $filename, $user."\n".$lockTime );
   627     } else {
   628         unlink $filename ||
   629           throw Error::Simple( 'RCS: failed to delete '.$filename.': '.$! );
   630     }
   631 }
   632 
   633 =pod
   634 
   635 ---++ ObjectMethod isLocked( ) -> ($user, $time)
   636 
   637 See if a twiki lock exists. Return the lock user and lock time if it does.
   638 
   639 =cut
   640 
   641 sub isLocked {
   642     my( $this ) = @_;
   643 
   644     my $filename = _controlFileName( $this, 'lock');
   645     if ( -e $filename ) {
   646         my $t = readFile( $this, $filename );
   647         return split( /\s+/, $t, 2 );
   648     }
   649     return ( undef, undef );
   650 }
   651 
   652 =pod
   653 
   654 ---++ ObjectMethod setLease( $lease )
   655 
   656    * =$lease= reference to lease hash, or undef if the existing lease is to be cleared.
   657 
   658 Set an lease on the topic.
   659 
   660 =cut
   661 
   662 sub setLease {
   663     my( $this, $lease ) = @_;
   664 
   665     my $filename = _controlFileName( $this, 'lease');
   666     if( $lease ) {
   667         saveFile( $this, $filename, join( "\n", %$lease ) );
   668     } elsif( -e $filename ) {
   669         unlink $filename ||
   670           throw Error::Simple( 'RCS: failed to delete '.$filename.': '.$! );
   671     }
   672 }
   673 
   674 =pod
   675 
   676 ---++ ObjectMethod getLease() -> $lease
   677 
   678 Get the current lease on the topic.
   679 
   680 =cut
   681 
   682 sub getLease {
   683     my( $this ) = @_;
   684 
   685     my $filename = _controlFileName( $this, 'lease');
   686     if ( -e $filename ) {
   687         my $t = readFile( $this, $filename );
   688         my $lease = { split( /\r?\n/, $t ) };
   689         return $lease;
   690     }
   691     return undef;
   692 }
   693 
   694 =pod
   695 
   696 ---++ ObjectMethod removeSpuriousLeases( $web )
   697 
   698 Remove leases that are not related to a topic. These can get left behind in
   699 some store implementations when a topic is created, but never saved.
   700 
   701 =cut
   702 
   703 sub removeSpuriousLeases {
   704     my( $this ) = @_;
   705     my $web = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/';
   706     if (opendir(W, $web)) {
   707         foreach my $f (readdir(W)) {
   708             if ($f =~ /^(.*)\.lease$/) {
   709                 if (! -e "$1.txt,v") {
   710                     unlink($f);
   711                 }
   712             }
   713         }
   714         closedir(W);
   715     }
   716 }
   717 
   718 sub saveStream {
   719     my( $this, $fh ) = @_;
   720 
   721     ASSERT($fh) if DEBUG;
   722 
   723     mkPathTo( $this->{file} );
   724     open( F, '>'.$this->{file} ) ||
   725         throw Error::Simple( 'RCS: open '.$this->{file}.' failed: '.$! );
   726     binmode( F ) ||
   727       throw Error::Simple( 'RCS: failed to binmode '.$this->{file}.': '.$! );
   728     my $text;
   729     binmode(F);
   730     while( read( $fh, $text, 1024 )) {
   731         print F $text;
   732     }
   733     close(F) ||
   734         throw Error::Simple( 'RCS: close '.$this->{file}.' failed: '.$! );;
   735 
   736     chmod( $TWiki::cfg{RCS}{filePermission}, $this->{file} );
   737 
   738     return '';
   739 }
   740 
   741 sub _copyFile {
   742     my( $from, $to ) = @_;
   743 
   744     mkPathTo( $to );
   745     unless( File::Copy::copy( $from, $to ) ) {
   746         throw Error::Simple( 'RCS: copy '.$from.' to '.$to.' failed: '.$! );
   747     }
   748 }
   749 
   750 sub _moveFile {
   751     my( $from, $to ) = @_;
   752 
   753     mkPathTo( $to );
   754     unless( File::Copy::move( $from, $to ) ) {
   755         throw Error::Simple( 'RCS: move '.$from.' to '.$to.' failed: '.$! );
   756     }
   757 }
   758 
   759 sub saveFile {
   760     my( $this, $name, $text ) = @_;
   761 
   762     mkPathTo( $name );
   763 
   764     open( FILE, '>'.$name ) ||
   765       throw Error::Simple( 'RCS: failed to create file '.$name.': '.$! );
   766     binmode( FILE ) ||
   767       throw Error::Simple( 'RCS: failed to binmode '.$name.': '.$! );
   768     print FILE $text;
   769     close( FILE) ||
   770       throw Error::Simple( 'RCS: failed to create file '.$name.': '.$! );
   771     return undef;
   772 }
   773 
   774 sub readFile {
   775     my( $this, $name ) = @_;
   776     my $data;
   777     if( open( IN_FILE, '<', $name )) {
   778         binmode( IN_FILE );
   779         local $/ = undef;
   780         $data = <IN_FILE>;
   781         close( IN_FILE );
   782     }
   783     $data ||= '';
   784     return $data;
   785 }
   786 
   787 sub mkTmpFilename {
   788     my $tmpdir = File::Spec->tmpdir();
   789     my $file = _mktemp( 'twikiAttachmentXXXXXX', $tmpdir );
   790     return File::Spec->catfile($tmpdir, $file);
   791 }
   792 
   793 # Adapted from CPAN - File::MkTemp
   794 sub _mktemp {
   795     my ($template,$dir,$ext,$keepgen,$lookup);
   796     my (@template,@letters);
   797 
   798     ASSERT(@_ == 1 || @_ == 2 || @_ == 3) if DEBUG;
   799 
   800     ($template,$dir,$ext) = @_;
   801     @template = split //, $template;
   802 
   803     ASSERT($template =~ /XXXXXX$/) if DEBUG;
   804 
   805     if ($dir){
   806         ASSERT(-e $dir) if DEBUG;
   807     }
   808 
   809     @letters =
   810       split(//,'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ');
   811 
   812     $keepgen = 1;
   813 
   814     while ($keepgen){
   815         for (my $i = $#template; $i >= 0 && ($template[$i] eq 'X'); $i--){
   816             $template[$i] = $letters[int(rand 52)];
   817         }
   818 
   819         undef $template;
   820 
   821         $template = pack 'a' x @template, @template;
   822 
   823         $template = $template . $ext if ($ext);
   824 
   825         if ($dir){
   826             $lookup = File::Spec->catfile($dir, $template);
   827             $keepgen = 0 unless (-e $lookup);
   828         } else {
   829             $keepgen = 0;
   830         }
   831 
   832         next if $keepgen == 0;
   833     }
   834 
   835     return($template);
   836 }
   837 
   838 # remove a directory and all subdirectories.
   839 sub _rmtree {
   840     my $root = shift;
   841 
   842     if( opendir( D, $root ) ) {
   843         foreach my $entry ( grep { !/^\.+$/ } readdir( D ) ) {
   844             $entry =~ /^(.*)$/;
   845             $entry = $root.'/'.$1;
   846             if( -d $entry ) {
   847                 _rmtree( $entry );
   848             } elsif( !unlink( $entry ) && -e $entry ) {
   849                 if ($TWiki::cfg{OS} ne 'WINDOWS') {
   850                     throw Error::Simple( 'RCS: Failed to delete file '.
   851                                            $entry.': '.$! );
   852                 } else {
   853                     # Windows sometimes fails to delete files when
   854                     # subprocesses haven't exited yet, because the
   855                     # subprocess still has the file open. Live with it.
   856                     print STDERR 'WARNING: Failed to delete file ',
   857                                            $entry,": $!\n";
   858                 }
   859             }
   860         }
   861         closedir(D);
   862 
   863         if (!rmdir( $root )) {
   864             if ($TWiki::cfg{OS} ne 'WINDOWS') {
   865                 throw Error::Simple( 'RCS: Failed to delete '.$root.': '.$! );
   866             } else {
   867                 print STDERR 'WARNING: Failed to delete '.$root.': '.$!,"\n";
   868             }
   869         }
   870     }
   871 }
   872 
   873 =pod
   874 
   875 ---++ ObjectMethod getStream() -> \*STREAM
   876 
   877 Return a text stream that will supply the text stored in the topic.
   878 
   879 =cut
   880 
   881 sub getStream {
   882     my( $this ) = shift;
   883     my $strm;
   884     unless( open( $strm, '<'.$this->{file} )) {
   885         throw Error::Simple( 'RCS: stream open '.$this->{file}.
   886                                ' failed: '.$! );
   887     }
   888     return $strm;
   889 }
   890 
   891 =pod
   892 
   893 ---++ ObjectMethod numRevisions() -> $integer
   894 
   895 Must be provided by subclasses.
   896 
   897 Find out how many revisions there are. If there is a problem, such
   898 as a nonexistent file, returns 0.
   899 
   900 *Virtual method* - must be implemented by subclasses
   901 
   902 =cut
   903 
   904 =pod
   905 
   906 ---++ ObjectMethod initBinary()
   907 
   908 Initialise a binary file.
   909 
   910 Must be provided by subclasses.
   911 
   912 *Virtual method* - must be implemented by subclasses
   913 
   914 =cut
   915 
   916 =pod
   917 
   918 ---++ ObjectMethod initText()
   919 
   920 Initialise a text file.
   921 
   922 Must be provided by subclasses.
   923 
   924 *Virtual method* - must be implemented by subclasses
   925 
   926 =cut
   927 
   928 =pod
   929 
   930 ---++ ObjectMethod addRevisionFromText($text, $comment, $user, $date)
   931 
   932 Add new revision. Replace file with text.
   933    * =$text= of new revision
   934    * =$comment= checkin comment
   935    * =$user= is a wikiname.
   936    * =$date= in epoch seconds; may be ignored
   937 
   938 *Virtual method* - must be implemented by subclasses
   939 
   940 =pod
   941 
   942 ---++ ObjectMethod addRevisionFromStream($fh, $comment, $user, $date)
   943 
   944 Add new revision. Replace file with contents of stream.
   945    * =$fh= filehandle for contents of new revision
   946    * =$comment= checkin comment
   947    * =$user= is a wikiname.
   948    * =$date= in epoch seconds; may be ignored
   949 
   950 *Virtual method* - must be implemented by subclasses
   951 
   952 =cut
   953 
   954 =pod
   955 
   956 ---++ ObjectMethod replaceRevision($text, $comment, $user, $date)
   957 
   958 Replace the top revision.
   959    * =$text= is the new revision
   960    * =$date= is in epoch seconds.
   961    * =$user= is a wikiname.
   962    * =$comment= is a string
   963 
   964 *Virtual method* - must be implemented by subclasses
   965 
   966 =cut
   967 
   968 =pod
   969 
   970 ---++ ObjectMethod deleteRevision()
   971 
   972 Delete the last revision - do nothing if there is only one revision
   973 
   974 *Virtual method* - must be implemented by subclasses
   975 
   976 =cut to implementation
   977 
   978 =pod
   979 
   980 ---++ ObjectMethod revisionDiff (   $rev1, $rev2, $contextLines  ) -> \@diffArray
   981 
   982 rev2 newer than rev1.
   983 Return reference to an array of [ diffType, $right, $left ]
   984 
   985 *Virtual method* - must be implemented by subclasses
   986 
   987 =cut
   988 
   989 =pod
   990 
   991 ---++ ObjectMethod getRevision($version) -> $text
   992 
   993 Get the text for a given revision. The version number must be an integer.
   994 
   995 *Virtual method* - must be implemented by subclasses
   996 
   997 =cut
   998 
   999 =pod
  1000 
  1001 ---++ ObjectMethod getRevisionAtTime($time) -> $rev
  1002 
  1003 Get a single-digit version number for the rev that was alive at the
  1004 given epoch-secs time, or undef it none could be found.
  1005 
  1006 *Virtual method* - must be implemented by subclasses
  1007 
  1008 =cut
  1009 
  1010 
  1011 =pod
  1012 
  1013 ---++ ObjectMethod getAttachmentAttributes($web, $topic, $attachment)
  1014 
  1015 returns [stat] for any given web, topic, $attachment
  1016 SMELL - should this return a hash of arbitrary attributes so that 
  1017 SMELL + attributes supported by the underlying filesystem are supported
  1018 SMELL + (eg: windows directories supporting photo "author", "dimension" fields)
  1019 
  1020 =cut
  1021 
  1022 sub getAttachmentAttributes {
  1023 	my( $this, $web, $topic, $attachment ) = @_;
  1024     ASSERT(defined $attachment) if DEBUG;
  1025 	
  1026 	my $dir = dirForTopicAttachments($web, $topic);
  1027    	my @stat = stat ($dir."/".$attachment);
  1028 
  1029 	return @stat;
  1030 }
  1031 
  1032 # as long as stat is defined, return an emulated set of attributes for that
  1033 # attachment.
  1034 sub _constructAttributesForAutoAttached {
  1035     my ($file, $stat) = @_;
  1036 
  1037     my %pairs = (
  1038         name    => $file,
  1039         version => '',
  1040         path    => $file,
  1041         size    => $stat->[7],
  1042         date    => $stat->[9], 
  1043 #        user    => 'UnknownUser',  #safer _not_ to default - TWiki will fill it in when it needs to
  1044         comment => '',
  1045         attr    => '',
  1046         autoattached => '1'
  1047        );
  1048 
  1049     if ($#$stat > 0) {
  1050         return \%pairs;
  1051     } else {
  1052         return undef;
  1053     }
  1054 }
  1055 
  1056 
  1057 =pod
  1058 
  1059 ---++ ObjectMethod getAttachmentList($web, $topic)
  1060 
  1061 returns {} of filename => { key => value, key2 => value } for any given web, topic
  1062 Ignores files starting with _ or ending with ,v
  1063 
  1064 =cut
  1065 
  1066 sub getAttachmentList {
  1067 	my( $this, $web, $topic ) = @_;
  1068 	my $dir = dirForTopicAttachments($web, $topic);
  1069 		
  1070     opendir DIR, $dir || return '';
  1071     my %attachmentList = ();
  1072     my @files = sort grep { m/^[^\.*_]/ } readdir( DIR );
  1073     @files = grep { !/.*,v/ } @files;
  1074     foreach my $attachment ( @files ) {
  1075     	my @stat = stat ($dir."/".$attachment);
  1076         $attachmentList{$attachment} = _constructAttributesForAutoAttached($attachment, \@stat);
  1077     }
  1078     closedir( DIR );
  1079     return %attachmentList;
  1080 }
  1081 
  1082 sub dirForTopicAttachments {
  1083     my ($web, $topic ) = @_;
  1084     return $TWiki::cfg{PubDir}.'/'.$web.'/'.$topic;
  1085 }
  1086 
  1087 =pod
  1088 
  1089 ---++ ObjectMethod stringify()
  1090 
  1091 Generate string representation for debugging
  1092 
  1093 =cut
  1094 
  1095 sub stringify {
  1096     my $this = shift;
  1097     my @reply;
  1098     foreach my $key qw(web topic attachment file rcsFile) {
  1099         if (defined $this->{$key}) {
  1100             push(@reply, "$key=$this->{$key}");
  1101         }
  1102     }
  1103     return join(',', @reply);
  1104 }
  1105 
  1106 # Chop out recognisable path components to prevent hacking based on error
  1107 # messages
  1108 sub hidePath {
  1109     my ( $this, $erf ) = @_;
  1110     $erf =~ s#.*(/\w+/\w+\.[\w,]*)$#...$1#;
  1111     return $erf;
  1112 }
  1113 
  1114 =pod
  1115 
  1116 ---++ ObjectMethod recordChange($user, $rev, $more)
  1117 Record that the file changed
  1118 
  1119 =cut
  1120 
  1121 sub recordChange {
  1122     my( $this, $user, $rev, $more ) = @_;
  1123     $more ||= '';
  1124 
  1125     # Store wikiname in the change log
  1126     $user = $this->{session}->{users}->getWikiName( $user );
  1127 
  1128     my $file = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/.changes';
  1129     return unless( !-e $file || -w $file ); # no point if we can't write it
  1130 
  1131     my @changes =
  1132       map {
  1133           my @row = split(/\t/, $_, 5);
  1134           \@row }
  1135         split( /[\r\n]+/, readFile( $this, $file ));
  1136 
  1137     # Forget old stuff
  1138     my $cutoff = time() - $TWiki::cfg{Store}{RememberChangesFor};
  1139     while (scalar(@changes) && $changes[0]->[2] < $cutoff) {
  1140         shift( @changes );
  1141     }
  1142 
  1143     # Add the new change to the end of the file
  1144     push( @changes, [ $this->{topic}, $user, time(), $rev, $more ] );
  1145     my $text = join( "\n", map { join( "\t", @$_); } @changes );
  1146 
  1147     saveFile( $this, $file, $text );
  1148 }
  1149 
  1150 =pod
  1151 
  1152 ---++ ObjectMethod eachChange($since) -> $iterator
  1153 
  1154 Return iterator over changes - see Store for details
  1155 
  1156 =cut
  1157 
  1158 sub eachChange {
  1159     my( $this, $since ) = @_;
  1160     my $file = $TWiki::cfg{DataDir}.'/'.$this->{web}.'/.changes';
  1161     require TWiki::ListIterator;
  1162 
  1163     if( -r $file ) {
  1164         # SMELL: could use a LineIterator to avoid reading the whole
  1165         # file, but it hardle seems worth it.
  1166         my @changes =
  1167           map {
  1168               # Create a hash for this line
  1169               { topic => $_->[0], user => $_->[1], time => $_->[2],
  1170                   revision => $_->[3], more => $_->[4] };
  1171           }
  1172             grep {
  1173                 # Filter on time
  1174                 $_->[2] && $_->[2] >= $since
  1175             }
  1176               map {
  1177                   # Split line into an array
  1178                   my @row = split(/\t/, $_, 5);
  1179                   \@row;
  1180               }
  1181                 reverse split( /[\r\n]+/, readFile( $this, $file ));
  1182 
  1183         return new TWiki::ListIterator( \@changes );
  1184     } else {
  1185         my $changes = [];
  1186         return new TWiki::ListIterator( $changes );
  1187     }
  1188 }
  1189 
  1190 1;