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