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