1 rizwank 1.1 # Module of TWiki Collaboration Platform, http://TWiki.org/
2 #
3 # Copyright (C) 1999-2004 Peter Thoeny, peter@thoeny.com
4 #
5 # For licensing info read license.txt file in the TWiki root.
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License
8 # as published by the Free Software Foundation; either version 2
9 # of the License, or (at your option) any later version.
10 #
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details, published at
15 # http://www.gnu.org/copyleft/gpl.html
16 #
17 # Notes:
18 # - Latest version at http://twiki.org/
19 # - Installation instructions in $dataDir/Main/TWikiDocumentation.txt
20 # - Customize variables in TWiki.cfg when installing TWiki.
21 # - Optionally change TWiki.pm for custom extensions of rendering rules.
22 rizwank 1.1 # - Upgrading TWiki is easy as long as you do not customize TWiki.pm.
23 # - Check web server error logs for errors, i.e. % tail /var/log/httpd/error_log
24 #
25 # 20000917 - NicholasLee : Split file/storage related functions from wiki.pm
26 # 200105 - JohnTalintyre : AttachmentsUnderRevisionControl & meta data in topics
27 # 200106 - JohnTalintyre : Added Form capability (replaces Category tables)
28 # 200401 - RafaelAlvarez : Added a new Plugin callback (afterSaveHandler)
29 =begin twiki
30
31 ---+ TWiki::Store Module
32
33 This module hosts the generic storage backend.
34
35 =cut
36
37 package TWiki::Store;
38
39 use File::Copy;
40 use Time::Local;
41
42 use strict;
43 rizwank 1.1
44 # 'Use locale' for internationalisation of Perl sorting in getTopicNames
45 # and other routines - main locale settings are done in TWiki::setupLocale
46 BEGIN {
47 # Do a dynamic 'use locale' for this module
48 if( $TWiki::useLocale ) {
49 require locale;
50 import locale ();
51 }
52 }
53
54 # FIXME: Move elsewhere?
55 # template variable hash: (built from %TMPL:DEF{"key"}% ... %TMPL:END%)
56 use vars qw( %templateVars ); # init in TWiki.pm so okay for modPerl
57
58 # ===========================
59 =pod
60
61 ---++ sub initialize ()
62
63 Not yet documented.
64 rizwank 1.1
65 =cut
66
67 sub initialize
68 {
69 %templateVars = ();
70 eval "use TWiki::Store::$TWiki::storeTopicImpl;";
71 }
72
73 =pod
74
75 ---++ sub _traceExec ()
76
77 Normally writes no output, uncomment writeDebug line to get output of all RCS etc command to debug file
78
79 =cut
80
81 sub _traceExec
82 {
83 #my( $cmd, $result ) = @_;
84 #TWiki::writeDebug( "Store exec: $cmd -> $result" );
85 rizwank 1.1 }
86
87 =pod
88
89 ---++ sub writeDebug ()
90
91 Not yet documented.
92
93 =cut
94
95 sub writeDebug
96 {
97 #TWiki::writeDebug( "Store: $_[0]" );
98 }
99
100 =pod
101
102 ---++ sub _getTopicHandler ( $web, $topic, $attachment )
103
104 Not yet documented.
105
106 rizwank 1.1 =cut
107
108 sub _getTopicHandler
109 {
110 my( $web, $topic, $attachment ) = @_;
111
112 $attachment = "" if( ! $attachment );
113
114 my $handlerName = "TWiki::Store::$TWiki::storeTopicImpl";
115
116 my $handler = $handlerName->new( $web, $topic, $attachment, @TWiki::storeSettings );
117 return $handler;
118 }
119
120
121 =pod
122
123 ---++ sub normalizeWebTopicName ( $theWeb, $theTopic )
124
125 Normalize a Web.TopicName
126 <pre>
127 rizwank 1.1 Input: Return:
128 ( "Web", "Topic" ) ( "Web", "Topic" )
129 ( "", "Topic" ) ( "Main", "Topic" )
130 ( "", "" ) ( "Main", "WebHome" )
131 ( "", "Web/Topic" ) ( "Web", "Topic" )
132 ( "", "Web.Topic" ) ( "Web", "Topic" )
133 ( "Web1", "Web2.Topic" ) ( "Web2", "Topic" )
134 </pre>
135 Note: Function renamed from getWebTopic
136
137 =cut
138
139 sub normalizeWebTopicName
140 {
141 my( $theWeb, $theTopic ) = @_;
142
143 if( $theTopic =~ m|^([^.]+)[\.\/](.*)$| ) {
144 $theWeb = $1;
145 $theTopic = $2;
146 }
147 $theWeb = $TWiki::webName unless( $theWeb );
148 rizwank 1.1 $theTopic = $TWiki::topicName unless( $theTopic );
149
150 return( $theWeb, $theTopic );
151 }
152
153
154 =pod
155
156 ---++ sub erase ( $web, $topic )
157
158 Get rid of a topic and its attachments completely
159 Intended for TEST purposes.
160 Use with GREAT CARE as file will be gone, including RCS history
161
162 =cut
163
164 sub erase
165 {
166 my( $web, $topic ) = @_;
167
168 my $topicHandler = _getTopicHandler( $web, $topic );
169 rizwank 1.1 $topicHandler->_delete();
170
171 writeLog( "erase", "$web.$topic", "" );
172 }
173
174 =pod
175
176 ---++ sub moveAttachment ( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment )
177
178 Move an attachment from one topic to another.
179 If there is a problem an error string is returned.
180 The caller to this routine should check that all topics are valid and
181 do lock on the topics.
182
183 =cut
184
185 sub moveAttachment
186 {
187 my( $oldWeb, $oldTopic, $newWeb, $newTopic, $theAttachment ) = @_;
188
189 my $topicHandler = _getTopicHandler( $oldWeb, $oldTopic, $theAttachment );
190 rizwank 1.1 my $error = $topicHandler->moveMe( $newWeb, $newTopic );
191 return $error if( $error );
192
193 # Remove file attachment from old topic
194 my( $meta, $text ) = readTopic( $oldWeb, $oldTopic );
195 my %fileAttachment = $meta->findOne( "FILEATTACHMENT", $theAttachment );
196 $meta->remove( "FILEATTACHMENT", $theAttachment );
197 $error .= saveNew( $oldWeb, $oldTopic, $text, $meta, "", "", "", "doUnlock", "dont notify", "" );
198
199 # Remove lock file
200 $topicHandler->setLock( "" );
201
202 # Add file attachment to new topic
203 ( $meta, $text ) = readTopic( $newWeb, $newTopic );
204
205 $fileAttachment{"movefrom"} = "$oldWeb.$oldTopic";
206 $fileAttachment{"moveby"} = $TWiki::userName;
207 $fileAttachment{"movedto"} = "$newWeb.$newTopic";
208 $fileAttachment{"movedwhen"} = time();
209 $meta->put( "FILEATTACHMENT", %fileAttachment );
210
211 rizwank 1.1 $error .= saveNew( $newWeb, $newTopic, $text, $meta, "", "", "", "doUnlock", "dont notify", "" );
212 # Remove lock file.
213 my $newTopicHandler = _getTopicHandler( $newWeb, $newTopic, $theAttachment );
214 $newTopicHandler->setLock( "" );
215
216 writeLog( "move", "$oldWeb.$oldTopic", "Attachment $theAttachment moved to $newWeb.$newTopic" );
217
218 return $error;
219 }
220
221 =pod
222
223 ---++ sub changeRefTo ( $text, $oldWeb, $oldTopic )
224
225 When moving a topic to another web, change within-web refs from this topic so that they'll work
226 when the topic is in the new web. I have a feeling this shouldn't be in Store.pm.
227
228 =cut
229
230 sub changeRefTo
231 {
232 rizwank 1.1 my( $text, $oldWeb, $oldTopic ) = @_;
233
234 my $preTopic = '^|[\*\s\[][-\(\s]*';
235 # I18N: match non-alpha before/after topic names
236 my $alphaNum = $TWiki::regex{mixedAlphaNum};
237 my $postTopic = '$|' . "[^${alphaNum}_.]" . '|\.\s';
238 my $metaPreTopic = '"|[\s[,\(-]';
239 my $metaPostTopic = "[^${alphaNum}_.]" . '|\.\s';
240
241 my $out = "";
242
243 # Get list of topics in $oldWeb, replace local refs to these topics with full web.topic
244 # references
245 my @topics = getTopicNames( $oldWeb );
246
247 my $insidePRE = 0;
248 my $insideVERBATIM = 0;
249 my $noAutoLink = 0;
250
251 foreach( split( /\n/, $text ) ) {
252 if( /^%META:TOPIC(INFO|MOVED)/ ) {
253 rizwank 1.1 $out .= "$_\n";
254 next;
255 }
256
257 # change state:
258 m|<pre>|i && ( $insidePRE = 1 );
259 m|</pre>|i && ( $insidePRE = 0 );
260 if( m|<verbatim>|i ) {
261 $insideVERBATIM = 1;
262 }
263 if( m|</verbatim>|i ) {
264 $insideVERBATIM = 0;
265 }
266 m|<noautolink>|i && ( $noAutoLink = 1 );
267 m|</noautolink>|i && ( $noAutoLink = 0 );
268
269 if( ! ( $insidePRE || $insideVERBATIM || $noAutoLink ) ) {
270 # Fairly inefficient, time will tell if this should be changed.
271 foreach my $topic ( @topics ) {
272 if( $topic ne $oldTopic ) {
273 if( /^%META:/ ) {
274 rizwank 1.1 s/^(%META:FILEATTACHMENT.*? user\=\")(\w)/$1$TWiki::TranslationToken$2/;
275 s/^(%META:TOPICMOVED.*? by\=\")(\w)/$1$TWiki::TranslationToken$2/;
276 s/($metaPreTopic)\Q$topic\E(?=$metaPostTopic)/$1$oldWeb.$topic/g;
277 s/$TWiki::TranslationToken//;
278 } else {
279 s/($preTopic)\Q$topic\E(?=$postTopic)/$1$oldWeb.$topic/g;
280 }
281 }
282 }
283 }
284 $out .= "$_\n";
285 }
286
287 return $out;
288 }
289
290
291 =pod
292
293 ---++ sub renameTopic ( $oldWeb, $oldTopic, $newWeb, $newTopic, $doChangeRefTo )
294
295 rizwank 1.1 Rename a topic, allowing for transfer between Webs
296 It is the responsibility of the caller to check for existence of webs,
297 topics & lock taken for topic
298
299 =cut
300
301 sub renameTopic
302 {
303 my( $oldWeb, $oldTopic, $newWeb, $newTopic, $doChangeRefTo ) = @_;
304
305 my $topicHandler = _getTopicHandler( $oldWeb, $oldTopic, "" );
306 my $error = $topicHandler->moveMe( $newWeb, $newTopic );
307
308 if( ! $error ) {
309 my $time = time();
310 my $user = $TWiki::userName;
311 my @args = (
312 "from" => "$oldWeb.$oldTopic",
313 "to" => "$newWeb.$newTopic",
314 "date" => "$time",
315 "by" => "$user" );
316 rizwank 1.1 my $fullText = readTopicRaw( $newWeb, $newTopic );
317 if( ( $oldWeb ne $newWeb ) && $doChangeRefTo ) {
318 $fullText = changeRefTo( $fullText, $oldWeb, $oldTopic );
319 }
320 my ( $meta, $text ) = _extractMetaData( $newWeb, $newTopic, $fullText );
321 $meta->put( "TOPICMOVED", @args );
322 saveNew( $newWeb, $newTopic, $text, $meta, "", "", "", "unlock" );
323 }
324
325 # Log rename
326 if( $TWiki::doLogRename ) {
327 writeLog( "rename", "$oldWeb.$oldTopic", "moved to $newWeb.$newTopic $error" );
328 }
329
330 # Remove old lock file
331 $topicHandler->setLock( "" );
332
333 return $error;
334 }
335
336
337 rizwank 1.1 =pod
338
339 ---++ sub updateReferingPages ( $oldWeb, $oldTopic, $wikiUserName, $newWeb, $newTopic, @refs )
340
341 Update pages that refer to the one being renamed/moved.
342
343 =cut
344
345 sub updateReferingPages
346 {
347 my ( $oldWeb, $oldTopic, $wikiUserName, $newWeb, $newTopic, @refs ) = @_;
348
349 my $lockFailure = 0;
350
351 my $result = "";
352 my $preTopic = '^|\W'; # Start of line or non-alphanumeric
353 my $postTopic = '$|\W'; # End of line or non-alphanumeric
354 my $spacedTopic = TWiki::Search::spacedTopic( $oldTopic );
355
356 while ( @refs ) {
357 my $type = shift @refs;
358 rizwank 1.1 my $item = shift @refs;
359 my( $itemWeb, $itemTopic ) = TWiki::Store::normalizeWebTopicName( "", $item );
360 if ( &TWiki::Store::topicIsLockedBy( $itemWeb, $itemTopic ) ) {
361 $lockFailure = 1;
362 } else {
363 my $resultText = "";
364 $result .= ":$item: , ";
365 #open each file, replace $topic with $newTopic
366 if ( &TWiki::Store::topicExists($itemWeb, $itemTopic) ) {
367 my $scantext = &TWiki::Store::readTopicRaw($itemWeb, $itemTopic);
368 if( ! &TWiki::Access::checkAccessPermission( "change", $wikiUserName, $scantext,
369 $itemWeb, $itemTopic ) ) {
370 # This shouldn't happen, as search will not return, but check to be on the safe side
371 &TWiki::writeWarning( "rename: attempt to change $itemWeb.$itemTopic without permission" );
372 next;
373 }
374 my $insidePRE = 0;
375 my $insideVERBATIM = 0;
376 my $noAutoLink = 0;
377 foreach( split( /\n/, $scantext ) ) {
378 if( /^%META:TOPIC(INFO|MOVED)/ ) {
379 rizwank 1.1 $resultText .= "$_\n";
380 next;
381 }
382 # FIXME This code is in far too many places - also in Search.pm and Store.pm
383 m|<pre>|i && ( $insidePRE = 1 );
384 m|</pre>|i && ( $insidePRE = 0 );
385 if( m|<verbatim>|i ) {
386 $insideVERBATIM = 1;
387 }
388 if( m|</verbatim>|i ) {
389 $insideVERBATIM = 0;
390 }
391 m|<noautolink>|i && ( $noAutoLink = 1 );
392 m|</noautolink>|i && ( $noAutoLink = 0 );
393
394 if( ! ( $insidePRE || $insideVERBATIM || $noAutoLink ) ) {
395 if( $type eq "global" ) {
396 my $insertWeb = ($itemWeb eq $newWeb) ? "" : "$newWeb.";
397 s/($preTopic)\Q$oldWeb.$oldTopic\E(?=$postTopic)/$1$insertWeb$newTopic/g;
398 } else {
399 # Only replace bare topic (i.e. not preceeded by web) if web of referring
400 rizwank 1.1 # topic is in original Web of topic that's being moved
401 if( $oldWeb eq $itemWeb ) {
402 my $insertWeb = ($oldWeb eq $newWeb) ? "" : "$newWeb.";
403 s/($preTopic)\Q$oldTopic\E(?=$postTopic)/$1$insertWeb$newTopic/g;
404 s/\[\[($spacedTopic)\]\]/[[$newTopic][$1]]/gi;
405 }
406 }
407 }
408 $resultText .= "$_\n";
409 }
410 my ( $meta, $text ) = &TWiki::Store::_extractMetaData( $itemWeb, $itemTopic, $resultText );
411 &TWiki::Store::saveTopic( $itemWeb, $itemTopic, $text, $meta, "", "unlock", "dontNotify", "" );
412 } else {
413 $result .= ";$item does not exist;";
414 }
415 }
416 }
417 return ( $lockFailure, $result );
418 }
419
420
421 rizwank 1.1 =pod
422
423 ---++ sub readTopicVersion ( $theWeb, $theTopic, $theRev )
424
425 Read a specific version of a topic
426 <pre>view: $text= &TWiki::Store::readTopicVersion( $topic, "1.$rev" );</pre>
427
428 =cut
429
430 sub readTopicVersion
431 {
432 my( $theWeb, $theTopic, $theRev ) = @_;
433 my $text = _readVersionNoMeta( $theWeb, $theTopic, $theRev );
434 my $meta = "";
435
436 ( $meta, $text ) = _extractMetaData( $theWeb, $theTopic, $text );
437
438 return( $meta, $text );
439 }
440
441 =pod
442 rizwank 1.1
443 ---++ sub _readVersionNoMeta ( $theWeb, $theTopic, $theRev )
444
445 Read a specific version of a topic
446
447 =cut
448
449 sub _readVersionNoMeta
450 {
451 my( $theWeb, $theTopic, $theRev ) = @_;
452 my $topicHandler = _getTopicHandler( $theWeb, $theTopic );
453
454 $theRev =~ s/^1\.//o;
455 return $topicHandler->getRevision( $theRev );
456 }
457
458 =pod
459
460 ---++ sub readAttachmentVersion ( $theWeb, $theTopic, $theAttachment, $theRev )
461
462 Not yet documented.
463 rizwank 1.1
464 =cut
465
466 sub readAttachmentVersion
467 {
468 my ( $theWeb, $theTopic, $theAttachment, $theRev ) = @_;
469
470 my $topicHandler = _getTopicHandler( $theWeb, $theTopic, $theAttachment );
471 $theRev =~ s/^1\.//o;
472 return $topicHandler->getRevision( $theRev );
473 }
474
475 =pod
476
477 ---++ sub getRevisionNumber ( $theWebName, $theTopic, $attachment )
478
479 Use meta information if available ...
480
481 =cut
482
483 sub getRevisionNumber
484 rizwank 1.1 {
485 my( $theWebName, $theTopic, $attachment ) = @_;
486 my $ret = getRevisionNumberX( $theWebName, $theTopic, $attachment );
487 ##TWiki::writeDebug( "Store: rev = $ret" );
488 if( ! $ret ) {
489 $ret = "1.1"; # Temporary
490 }
491
492 return $ret;
493 }
494
495
496 =pod
497
498 ---++ sub getRevisionNumberX ( $theWebName, $theTopic, $attachment )
499
500 Latest revision number. <br/>
501 Returns "" if there is no revision.
502
503 =cut
504
505 rizwank 1.1 sub getRevisionNumberX
506 {
507 my( $theWebName, $theTopic, $attachment ) = @_;
508 if( ! $theWebName ) {
509 $theWebName = $TWiki::webName;
510 }
511 if( ! $attachment ) {
512 $attachment = "";
513 }
514
515 my $topicHandler = _getTopicHandler( $theWebName, $theTopic, $attachment );
516 my $revs = $topicHandler->numRevisions();
517 $revs = "1.$revs" if( $revs );
518 return $revs;
519 }
520
521
522 =pod
523
524 ---++ sub getRevisionDiff ( $web, $topic, $rev1, $rev2, $contextLines )
525
526 rizwank 1.1 <pre>
527 rdiff: $diffArray = &TWiki::Store::getRevisionDiff( $webName, $topic, "1.$r2", "1.$r1", 3 );
528 </pre>
529 | Return: =\@diffArray= | reference to an array of [ diffType, $right, $left ] |
530
531 =cut
532
533 sub getRevisionDiff
534 {
535 my( $web, $topic, $rev1, $rev2, $contextLines ) = @_;
536
537 my $rcs = _getTopicHandler( $web, $topic );
538 my $r1 = substr( $rev1, 2 );
539 my $r2 = substr( $rev2, 2 );
540 my( $error, $diffArrayRef ) = $rcs->revisionDiff( $r1, $r2, $contextLines );
541 return $diffArrayRef;
542 }
543
544
545 # =========================
546 # Call getRevisionInfoFromMeta for faster response for topics
547 rizwank 1.1 # FIXME try and get rid of this it's a mess
548 # In direct calls changeToIsoDate always seems to be 1
549
550 =pod
551
552 ---+++ getRevisionInfo($theWebName, $theTopic, $theRev, $attachment, $topicHandler) ==> ( $date, $user, $rev, $comment )
553 | Description: | Get revision info of a topic |
554 | Parameter: =$theWebName= | Web name, optional, e.g. ="Main"= |
555 | Parameter: =$theTopic= | Topic name, required, e.g. ="TokyoOffice"= |
556 | Parameter: =$theRev= | revsion number, or tag name (can be in the format 1.2, or just the minor number) |
557 | Parameter: =$attachment= |attachment filename |
558 | Parameter: =$topicHandler= | internal store use only |
559 | Return: =( $date, $user, $rev, $comment )= | List with: ( last update date, login name of last user, minor part of top revision number ), e.g. =( 1234561, "phoeny", "5" )= |
560 | $date | in epochSec |
561 | $user | |
562 | $rev | TODO: this needs to be improves to contain the major number too (and what do we do is we have a different numbering system?) |
563 | $comment | WHAT COMMENT? |
564
565 =cut
566
567 sub getRevisionInfo
568 rizwank 1.1 {
569 my( $theWebName, $theTopic, $theRev, $attachment, $topicHandler ) = @_;
570 if( ! $theWebName ) {
571 $theWebName = $TWiki::webName;
572 }
573
574 $theRev = "" unless( $theRev );
575 $theRev =~ s/^1\.//o;
576
577 $topicHandler = _getTopicHandler( $theWebName, $theTopic, $attachment ) if( ! $topicHandler );
578 my( $rcsOut, $rev, $date, $user, $comment ) = $topicHandler->getRevisionInfo( $theRev );
579
580 return ( $date, $user, $rev, $comment );
581 }
582
583
584 =pod
585
586 ---++ sub topicIsLockedBy ( $theWeb, $theTopic )
587
588 | returns ( $lockUser, $lockTime ) | ( "", 0 ) if not locked |
589 rizwank 1.1
590 =cut
591
592 sub topicIsLockedBy
593 {
594 my( $theWeb, $theTopic ) = @_;
595
596 # pragmatic approach: Warn user if somebody else pressed the
597 # edit link within a time limit e.g. 1 hour
598
599 ( $theWeb, $theTopic ) = normalizeWebTopicName( $theWeb, $theTopic );
600
601 my $lockFilename = "$TWiki::dataDir/$theWeb/$theTopic.lock";
602 if( ( -e "$lockFilename" ) && ( $TWiki::editLockTime > 0 ) ) {
603 my $tmp = readFile( $lockFilename );
604 my( $lockUser, $lockTime ) = split( /\n/, $tmp );
605 if( $lockUser ne $TWiki::userName ) {
606 # time stamp of lock within editLockTime of current time?
607 my $systemTime = time();
608 # calculate remaining lock time in seconds
609 $lockTime = $lockTime + $TWiki::editLockTime - $systemTime;
610 rizwank 1.1 if( $lockTime > 0 ) {
611 # must warn user that it is locked
612 return( $lockUser, $lockTime );
613 }
614 }
615 }
616 return( "", 0 );
617 }
618
619
620 =pod
621
622 ---++ sub keyValue2list ( $args )
623
624 Not yet documented.
625
626 =cut
627
628 sub keyValue2list
629 {
630 my( $args ) = @_;
631 rizwank 1.1
632 my @res = ();
633
634 # Format of data is name="value" name1="value1" [...]
635 while( $args =~ s/\s*([^=]+)=\"([^"]*)\"//o ) { #" avoid confusing syntax highlighters
636 push @res, $1;
637 push @res, $2;
638 }
639
640 return @res;
641 }
642
643
644 =pod
645
646 ---++ sub metaAddTopicData ( $web, $topic, $rev, $meta, $forceDate, $forceUser )
647
648 Not yet documented.
649
650 =cut
651
652 rizwank 1.1 sub metaAddTopicData
653 {
654 my( $web, $topic, $rev, $meta, $forceDate, $forceUser ) = @_;
655
656 my $time = $forceDate || time();
657 my $user = $forceUser || $TWiki::userName;
658
659 my @args = (
660 "version" => "$rev",
661 "date" => "$time",
662 "author" => "$user",
663 "format" => $TWiki::formatVersion );
664 $meta->put( "TOPICINFO", @args );
665 }
666
667
668 =pod
669
670 ---++ sub saveTopicNew ( $web, $topic, $text, $metaData, $saveCmd, $doUnlock, $dontNotify, $dontLogSave )
671
672 Not yet documented.
673 rizwank 1.1
674 =cut
675
676 sub saveTopicNew
677 {
678 my( $web, $topic, $text, $metaData, $saveCmd, $doUnlock, $dontNotify, $dontLogSave ) = @_;
679 my $attachment = "";
680 my $meta = TWiki::Meta->new();
681 $meta->readArray( @$metaData );
682 saveNew( $web, $topic, $text, $meta, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify );
683 }
684
685 =pod
686
687 ---++ sub saveTopic ( $web, $topic, $text, $meta, $saveCmd, $doUnlock, $dontNotify, $dontLogSave, $forceDate )
688
689 Not yet documented.
690
691 =cut
692
693 sub saveTopic
694 rizwank 1.1 {
695 my( $web, $topic, $text, $meta, $saveCmd, $doUnlock, $dontNotify, $dontLogSave, $forceDate ) = @_;
696 my $attachment = "";
697 my $comment = "";
698
699 # FIXME: Inefficient code that hides meta data from Plugin callback
700 $text = $meta->write( $text ); # add meta data for Plugin callback
701 TWiki::Plugins::beforeSaveHandler( $text, $topic, $web );
702 $meta = TWiki::Meta->remove(); # remove all meta data
703 $text = $meta->read( $text ); # restore meta data
704
705 my $error = saveNew( $web, $topic, $text, $meta, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify, $comment, $forceDate );
706 $text = $meta->write( $text ); # add meta data for Plugin callback
707 TWiki::Plugins::afterSaveHandler( $text, $topic, $web, $error );
708 return $error;
709 }
710
711 =pod
712
713 ---++ sub saveAttachment ()
714
715 rizwank 1.1 Not yet documented.
716
717 =cut
718
719 sub saveAttachment
720 {
721 my( $web, $topic, $text, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify, $theComment, $theTmpFilename,
722 $forceDate) = @_;
723
724 writeDebug("saveAttachment");
725 my %attachmentAtt = ( attachment => $attachment,
726 tmpFilename => $theTmpFilename,
727 comment => $theComment,
728 user => $TWiki::userName
729 ); # pass a hash of stuff using keys
730
731 my $topicHandler = _getTopicHandler( $web, $topic, $attachment );
732 TWiki::Plugins::beforeAttachmentSaveHandler( \%attachmentAtt, $topic, $web );
733
734 $theComment = $attachmentAtt{comment};
735 my $error = $topicHandler->addRevision( $theTmpFilename, $theComment, $TWiki::userName );
736 rizwank 1.1 TWiki::Plugins::afterAttachmentSaveHandler( \%attachmentAtt, $topic, $web, $error );
737
738 $topicHandler->setLock( ! $doUnlock );
739
740 return $error;
741 }
742
743
744 =pod
745
746 ---++ sub save ( $web, $topic, $text, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify, $theComment, $forceDate )
747
748 Not yet documented.
749
750 =cut
751
752 sub save
753 {
754 my( $web, $topic, $text, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify, $theComment, $forceDate ) = @_;
755
756 # FIXME get rid of this routine
757 rizwank 1.1
758 my $meta = TWiki::Meta->new();
759
760 return saveNew( $web, $topic, $text, $meta, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify, $theComment, $forceDate );
761 }
762
763
764 =pod
765
766 ---++ sub _addMeta ( $web, $topic, $text, $attachment, $nextRev, $meta, $forceDate, $forceUser )
767
768 Add meta data to the topic.
769
770 =cut
771
772 sub _addMeta
773 {
774 my( $web, $topic, $text, $attachment, $nextRev, $meta, $forceDate, $forceUser ) = @_;
775
776 if( ! $attachment ) {
777 $nextRev = "1.1" if( ! $nextRev );
778 rizwank 1.1 metaAddTopicData( $web, $topic, $nextRev, $meta, $forceDate, $forceUser );
779 $text = $meta->write( $text );
780 }
781
782 return $text;
783 }
784
785
786 =pod
787
788 ---++ sub saveNew ( $web, $topic, $text, $meta, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify, $theComment, $forceDate )
789
790 Return non-null string if there is an (RCS) error. <br/>
791 FIXME: does rev info from meta work if user saves a topic with no change?
792
793 =cut
794
795 sub saveNew
796 {
797 my( $web, $topic, $text, $meta, $saveCmd, $attachment, $dontLogSave, $doUnlock, $dontNotify, $theComment, $forceDate ) = @_;
798 my $time = time();
799 rizwank 1.1 my $tmp = "";
800 my $rcsError = "";
801 my $dataError = "";
802
803 my $topicHandler = _getTopicHandler( $web, $topic, $attachment );
804
805 my $currentRev = $topicHandler->numRevisions();
806
807 my $nextRev = "";
808 if( ! $currentRev ) {
809 $nextRev = "1.1";
810 } else {
811 $nextRev = "1." . ($currentRev + 1);
812 }
813 $currentRev = "1." . $currentRev if( $currentRev );
814
815 if( ! $attachment ) {
816 # RCS requires a newline for the last line,
817 # so add newline if needed
818 $text =~ s/([^\n\r])$/$1\n/os;
819 }
820 rizwank 1.1
821 if( ! $theComment ) {
822 $theComment = "none";
823 }
824
825 #### Normal Save
826 if( ! $saveCmd ) {
827 $saveCmd = "";
828
829 # get time stamp of existing file
830 my $mtime1 = $topicHandler->getTimestamp();
831 my $mtime2 = time();
832
833 # how close time stamp of existing file to now?
834 if( abs( $mtime2 - $mtime1 ) < $TWiki::editLockTime ) {
835 # FIXME no previous topic?
836 my( $date, $user ) = getRevisionInfo( $web, $topic, $currentRev, $attachment, $topicHandler );
837 # TWiki::writeDebug( "Store::save date = $date" );
838 # same user?
839 if( ( $TWiki::doKeepRevIfEditLock ) && ( $user eq $TWiki::userName ) && $currentRev ) { # TODO shouldn't this also check to see if its still locked?
840 # replace last repository entry
841 rizwank 1.1 $saveCmd = "repRev";
842 if( $attachment ) {
843 $saveCmd = ""; # cmd option not supported for attachments.
844 }
845 }
846 }
847
848 if( $saveCmd ne "repRev" ) {
849 $text = _addMeta( $web, $topic, $text, $attachment, $nextRev, $meta, $forceDate );
850
851 $dataError = $topicHandler->addRevision( $text, $theComment, $TWiki::userName );
852 return $dataError if( $dataError );
853
854 $topicHandler->setLock( ! $doUnlock );
855
856 if( ! $dontNotify ) {
857 # update .changes
858 my( $fdate, $fuser, $frev ) = getRevisionInfo( $web, $topic, "", $attachment, $topicHandler );
859 $fdate = ""; # suppress warning
860 $fuser = ""; # suppress warning
861
862 rizwank 1.1 my @foo = split( /\n/, &readFile( "$TWiki::dataDir/$TWiki::webName/.changes" ) );
863 if( $#foo > 100 ) {
864 shift( @foo);
865 }
866 push( @foo, "$topic\t$TWiki::userName\t$time\t$frev" );
867 open( FILE, ">$TWiki::dataDir/$TWiki::webName/.changes" );
868 print FILE join( "\n", @foo )."\n";
869 close(FILE);
870 }
871
872 if( ( $TWiki::doLogTopicSave ) && ! ( $dontLogSave ) ) {
873 # write log entry
874 my $extra = "";
875 $extra .= "dontNotify" if( $dontNotify );
876 writeLog( "save", "$TWiki::webName.$topic", $extra );
877 }
878 }
879 }
880
881 #### Replace Revision Save
882 if( $saveCmd eq "repRev" ) {
883 rizwank 1.1 # fix topic by replacing last revision, but do not update .changes
884
885 # save topic with same userName and date
886 # FIXME why should date be the same if same user replacing with editLockTime?
887 my( $date, $user, $rev ) = getRevisionInfo( $web, $topic, "", $attachment, $topicHandler );
888 $rev = "1.$rev";
889
890 # Add one minute (make small difference, but not too big for notification)
891 my $epochSec = $date + 60; #TODO: this seems wrong. if editLockTime == 3600, and i edit, 30 mins later... why would the recorded date be 29 mins too early?
892 $text = _addMeta( $web, $topic, $text, $attachment, $rev,
893 $meta, $epochSec, $user );
894
895 my $dataError = $topicHandler->replaceRevision( $text, $theComment, $user, $epochSec );
896 return $dataError if( $dataError );
897 $topicHandler->setLock( ! $doUnlock );
898
899 if( ( $TWiki::doLogTopicSave ) && ! ( $dontLogSave ) ) {
900 # write log entry
901 my $extra = "repRev $rev ";
902 $extra .= &TWiki::userToWikiName( $user );
903 $date = &TWiki::formatTime( $epochSec, "rcs", "gmtime" );
904 rizwank 1.1 $extra .= " $date";
905 $extra .= " dontNotify" if( $dontNotify );
906 writeLog( "save", "$TWiki::webName.$topic", $extra );
907 }
908 }
909
910 #### Delete Revision
911 if( $saveCmd eq "delRev" ) {
912 # delete last revision
913
914 # delete last entry in repository (unlock, delete revision, lock operation)
915 my $rev = getRevisionNumber( $web, $topic );
916 if( $rev eq "1.1" ) {
917 # can't delete initial revision
918 return;
919 }
920 my $dataError = $topicHandler->deleteRevision();
921 return $dataError if( $dataError );
922
923 # restore last topic from repository
924 $topicHandler->restoreLatestRevision();
925 rizwank 1.1 $topicHandler->setLock( ! $doUnlock );
926
927 # delete entry in .changes : FIXME
928
929 if( $TWiki::doLogTopicSave ) {
930 # write log entry
931 writeLog( "cmd", "$TWiki::webName.$topic", "delRev $rev" );
932 }
933 }
934 return ""; # all is well
935 }
936
937 =pod
938
939 ---++ sub writeLog ( $action, $webTopic, $extra, $user )
940
941 Not yet documented.
942
943 =cut
944
945 sub writeLog
946 rizwank 1.1 {
947 my( $action, $webTopic, $extra, $user ) = @_;
948
949 # use local time for log, not UTC (gmtime)
950
951 my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime( time() );
952 my( $tmon) = $TWiki::isoMonth[$mon];
953 $year = sprintf( "%.4u", $year + 1900 ); # Y2K fix
954 my $time = sprintf( "%.2u ${tmon} %.2u - %.2u:%.2u", $mday, $year, $hour, $min );
955 my $yearmonth = sprintf( "%.4u%.2u", $year, $mon+1 );
956
957 my $wuserName = $user || $TWiki::userName;
958 $wuserName = &TWiki::userToWikiName( $wuserName );
959 my $remoteAddr = $ENV{'REMOTE_ADDR'} || "";
960 my $text = "| $time | $wuserName | $action | $webTopic | $extra | $remoteAddr |";
961
962 my $filename = $TWiki::logFilename;
963 $filename =~ s/%DATE%/$yearmonth/go;
964
965 if( open( FILE, ">>$filename" ) ) {
966 print FILE "$text\n";
967 rizwank 1.1 close( FILE );
968 } else {
969 print STDERR "Couldn't write \"$text\" to $filename: $!\n";
970 }
971 }
972
973 =pod
974
975 ---++ sub saveFile ( $name, $text )
976
977 Not yet documented.
978
979 =cut
980
981 sub saveFile
982 {
983 my( $name, $text ) = @_;
984
985 umask( 002 );
986 unless ( open( FILE, ">$name" ) ) {
987 warn "Can't create file $name - $!\n";
988 rizwank 1.1 return;
989 }
990 print FILE $text;
991 close( FILE);
992 }
993
994 =pod
995
996 ---++ sub lockTopic ( $name, $doUnlock )
997
998 Not yet documented.
999
1000 =cut
1001
1002 sub lockTopic
1003 {
1004 my ( $name, $doUnlock ) = @_;
1005
1006 lockTopicNew( $TWiki::webName, $name, $doUnlock );
1007 }
1008
1009 rizwank 1.1 =pod
1010
1011 ---++ sub lockTopicNew ( $theWeb, $theTopic, $doUnlock )
1012
1013 Not yet documented. <br/>
1014 Called from rename and =TWiki::Func=
1015
1016 =cut
1017
1018 sub lockTopicNew
1019 {
1020 my( $theWeb, $theTopic, $doUnlock ) = @_;
1021
1022 ( $theWeb, $theTopic ) = normalizeWebTopicName( $theWeb, $theTopic );
1023
1024 my $topicHandler = _getTopicHandler( $theWeb, $theTopic );
1025 $topicHandler->setLock( ! $doUnlock );
1026 }
1027
1028 =pod
1029
1030 rizwank 1.1 ---++ sub removeObsoleteTopicLocks ( $web )
1031
1032 Not yet documented.
1033
1034 =cut
1035
1036 sub removeObsoleteTopicLocks
1037 {
1038 my( $web ) = @_;
1039
1040 # Clean all obsolete .lock files in a web.
1041 # This should be called regularly, best from a cron job (called from mailnotify)
1042
1043 my $webDir = "$TWiki::dataDir/$web";
1044 opendir( DIR, "$webDir" );
1045 my @fileList = grep /\.lock$/, readdir DIR;
1046 closedir DIR;
1047 my $file = "";
1048 my $pathFile = "";
1049 my $lockUser = "";
1050 my $lockTime = 0;
1051 rizwank 1.1 my $systemTime = time();
1052 foreach $file ( @fileList ) {
1053 $pathFile = "$webDir/$file";
1054 $pathFile =~ /(.*)/;
1055 $pathFile = $1; # untaint file
1056 ( $lockUser, $lockTime ) = split( /\n/, readFile( "$pathFile" ) );
1057 $lockTime = 0 unless( $lockTime );
1058
1059 # time stamp of lock over one hour of current time?
1060 if( abs( $systemTime - $lockTime ) > $TWiki::editLockTime ) {
1061 # obsolete, so delete file
1062 unlink "$pathFile";
1063 }
1064 }
1065 }
1066
1067 =pod
1068
1069 ---++ Functions: Content Handling
1070
1071 ---+++ webExists( $web ) ==> $flag
1072 rizwank 1.1
1073 | Description: | Test if web exists |
1074 | Parameter: =$web= | Web name, required, e.g. ="Sandbox"= |
1075 | Return: =$flag= | ="1"= if web exists, ="0"= if not |
1076
1077 =cut
1078
1079 sub webExists
1080 {
1081 my( $theWeb ) = @_;
1082 return -e "$TWiki::dataDir/$theWeb";
1083 }
1084
1085 =pod
1086
1087 ---+++ topicExists( $web, $topic ) ==> $flag
1088
1089 | Description: | Test if topic exists |
1090 | Parameter: =$web= | Web name, optional, e.g. ="Main"= |
1091 | Parameter: =$topic= | Topic name, required, e.g. ="TokyoOffice"=, or ="Main.TokyoOffice"= |
1092 | Return: =$flag= | ="1"= if topic exists, ="0"= if not |
1093 rizwank 1.1
1094 =cut
1095
1096 sub topicExists
1097 {
1098 my( $theWeb, $theTopic ) = @_;
1099 ( $theWeb, $theTopic ) = normalizeWebTopicName( $theWeb, $theTopic );
1100 return -e "$TWiki::dataDir/$theWeb/$theTopic.txt";
1101 }
1102
1103 =pod
1104
1105 ---++ sub getRevisionInfoFromMeta ( $web, $topic, $meta )
1106
1107 Try and get from meta information in topic, if this can't be done then use RCS.
1108 Note there is no "1." prefix to this data
1109
1110 =cut
1111
1112 sub getRevisionInfoFromMeta
1113 {
1114 rizwank 1.1 my( $web, $topic, $meta ) = @_;
1115
1116 my( $date, $author, $rev );
1117 my %topicinfo = ();
1118
1119 if( $meta ) {
1120 %topicinfo = $meta->findOne( "TOPICINFO" );
1121 }
1122
1123 if( %topicinfo ) {
1124 # Stored as meta data in topic for faster access
1125 $date = $topicinfo{"date"} ;
1126 $author = $topicinfo{"author"};
1127 my $tmp = $topicinfo{"version"};
1128 $tmp =~ /1\.(.*)/o;
1129 $rev = $1;
1130 } else {
1131 # Get data from RCS
1132 ( $date, $author, $rev ) = getRevisionInfo( $web, $topic, "" );
1133 }
1134
1135 rizwank 1.1 # writeDebug( "rev = $rev" );
1136
1137 return( $date, $author, $rev );
1138 }
1139
1140 =pod
1141
1142 ---++ sub convert2metaFormat ( $web, $topic, $text )
1143
1144 Not yet documented.
1145
1146 =cut
1147
1148 sub convert2metaFormat
1149 {
1150 my( $web, $topic, $text ) = @_;
1151
1152 my $meta = TWiki::Meta->new();
1153 $text = $meta->read( $text );
1154
1155 if ( $text =~ /<!--TWikiAttachment-->/ ) {
1156 rizwank 1.1 $text = TWiki::Attach::migrateToFileAttachmentMacro( $meta, $text );
1157 }
1158
1159 if ( $text =~ /<!--TWikiCat-->/ ) {
1160 $text = TWiki::Form::upgradeCategoryTable( $web, $topic, $meta, $text );
1161 }
1162
1163 return( $meta, $text );
1164 }
1165
1166 =pod
1167
1168 ---++ sub _extractMetaData ( $web, $topic, $fulltext )
1169
1170 Expect meta data at top of file, but willing to accept it anywhere.
1171 If we have an old file format without meta data, then convert.
1172
1173 =cut
1174
1175 sub _extractMetaData
1176 {
1177 rizwank 1.1 my( $web, $topic, $fulltext ) = @_;
1178
1179 my $meta = TWiki::Meta->new();
1180 my $text = $meta->read( $fulltext );
1181
1182
1183 # If there is no meta data then convert
1184 if( ! $meta->count( "TOPICINFO" ) ) {
1185 ( $meta, $text ) = convert2metaFormat( $web, $topic, $text );
1186 } else {
1187 my %topicinfo = $meta->findOne( "TOPICINFO" );
1188 if( $topicinfo{"format"} eq "1.0beta" ) {
1189 # This format used live at DrKW for a few months
1190 if( $text =~ /<!--TWikiCat-->/ ) {
1191 $text = TWiki::Form::upgradeCategoryTable( $web, $topic, $meta, $text );
1192 }
1193
1194 TWiki::Attach::upgradeFrom1v0beta( $meta );
1195
1196 if( $meta->count( "TOPICMOVED" ) ) {
1197 my %moved = $meta->findOne( "TOPICMOVED" );
1198 rizwank 1.1 $moved{"by"} = TWiki::wikiToUserName( $moved{"by"} );
1199 $meta->put( "TOPICMOVED", %moved );
1200 }
1201 }
1202 }
1203
1204 return( $meta, $text );
1205 }
1206
1207 =pod
1208
1209 ---++ sub getFileName ( $theWeb, $theTopic, $theAttachment )
1210
1211 Not yet documented. <br/>
1212 *FIXME - get rid of this because uses private part of handler*
1213
1214 =cut
1215
1216 sub getFileName
1217 {
1218 my( $theWeb, $theTopic, $theAttachment ) = @_;
1219 rizwank 1.1
1220 my $topicHandler = _getTopicHandler( $theWeb, $theTopic, $theAttachment );
1221 return $topicHandler->{file};
1222 }
1223
1224 =pod
1225
1226 ---++ sub readTopMeta ( $theWeb, $theTopic )
1227
1228 Just read the meta data at the top of the topic. <br/>
1229 Generalise for Codev.DataFramework, but needs to be fast because
1230 of use by view script.
1231
1232 =cut
1233
1234 sub readTopMeta
1235 {
1236 my( $theWeb, $theTopic ) = @_;
1237
1238 my $topicHandler = _getTopicHandler( $theWeb, $theTopic );
1239 my $filename = getFileName( $theWeb, $theTopic );
1240 rizwank 1.1
1241 my $data = "";
1242 my $line;
1243 $/ = "\n"; # read line by line
1244 open( IN_FILE, "<$filename" ) || return "";
1245 while( ( $line = <IN_FILE> ) ) {
1246 if( $line !~ /^%META:/ ) {
1247 last;
1248 } else {
1249 $data .= $line;
1250 }
1251 }
1252
1253 my( $meta, $text ) = _extractMetaData( $theWeb, $theTopic, $data );
1254
1255 close( IN_FILE );
1256
1257 return $meta;
1258 }
1259
1260 =pod
1261 rizwank 1.1
1262 ---++ readTopic( $web, $topic, $internal )
1263 Return value: ( $metaObject, $topicText )
1264
1265 Reads the most recent version of a topic. If $internal is false, view
1266 permission will be required for the topic read to be successful. A failed
1267 topic read is indicated by setting $TWiki::readTopicPermissionFailed.
1268
1269 The metadata and topic text are returned separately, with the metadata in a
1270 TWiki::Meta object. (The topic text is, as usual, just a string.)
1271
1272 =cut
1273
1274 sub readTopic
1275 {
1276 my( $theWeb, $theTopic, $internal ) = @_;
1277
1278 my $fullText = readTopicRaw( $theWeb, $theTopic, "", $internal );
1279
1280 my ( $meta, $text ) = _extractMetaData( $theWeb, $theTopic, $fullText );
1281
1282 rizwank 1.1 return( $meta, $text );
1283 }
1284
1285 =pod
1286
1287 ---++ sub readWebTopic ( $theWeb, $theName )
1288
1289 Not yet documented.
1290
1291 =cut
1292
1293 sub readWebTopic
1294 {
1295 my( $theWeb, $theName ) = @_;
1296 my $text = &readFile( "$TWiki::dataDir/$theWeb/$theName.txt" );
1297
1298 return $text;
1299 }
1300
1301 =pod
1302
1303 rizwank 1.1 ---++ readTopicRaw( $web, $topic, $version, $internal )
1304 Return value: $topicText
1305
1306 Reads a topic; the most recent version is used unless $version is specified.
1307 If $internal is false, view access permission will be checked. If permission
1308 is not granted, then an error message will be returned in $text, and set in
1309 $TWiki::readTopicPermissionFailed.
1310
1311 =cut
1312
1313 sub readTopicRaw
1314 {
1315 my( $theWeb, $theTopic, $theVersion, $internal ) = @_;
1316
1317 #SVEN - test if theTopic contains a webName to override $theWeb
1318 ( $theWeb, $theTopic ) = normalizeWebTopicName( $theWeb, $theTopic );
1319
1320 my $text = "";
1321 if( ! $theVersion ) {
1322 $text = &readFile( "$TWiki::dataDir/$theWeb/$theTopic.txt" );
1323 } else {
1324 rizwank 1.1 $text = _readVersionNoMeta( $theWeb, $theTopic, $theVersion);
1325 }
1326
1327 my $viewAccessOK = 1;
1328 unless( $internal ) {
1329 $viewAccessOK = &TWiki::Access::checkAccessPermission( "view", $TWiki::wikiUserName, $text, $theTopic, $theWeb );
1330 # TWiki::writeDebug( "readTopicRaw $viewAccessOK $TWiki::wikiUserName $theWeb $theTopic" );
1331 }
1332
1333 unless( $viewAccessOK ) {
1334 # FIXME: TWiki::Func::readTopicText will break if the following text changes
1335 $text = "No permission to read topic $theWeb.$theTopic - perhaps you need to log in?\n";
1336 # Could note inability to read so can divert to viewauth or similar
1337 $TWiki::readTopicPermissionFailed = "$TWiki::readTopicPermissionFailed $theWeb.$theTopic";
1338 }
1339
1340 return $text;
1341 }
1342
1343
1344 =pod
1345 rizwank 1.1
1346 ---++ sub readTemplateTopic ( $theTopicName )
1347
1348 Not yet documented.
1349
1350 =cut
1351
1352 sub readTemplateTopic
1353 {
1354 my( $theTopicName ) = @_;
1355
1356 $theTopicName =~ s/$TWiki::securityFilter//go; # zap anything suspicious
1357
1358 # try to read in current web, if not read from TWiki web
1359
1360 my $web = $TWiki::twikiWebname;
1361 if( topicExists( $TWiki::webName, $theTopicName ) ) {
1362 $web = $TWiki::webName;
1363 }
1364 return readTopic( $web, $theTopicName );
1365 }
1366 rizwank 1.1
1367 =pod
1368
1369 ---++ _readTemplateFile ( $theName, $theSkin )
1370 Return value: raw template text, or "" if read fails
1371
1372 WARNING! THIS FUNCTION DEPENDS ON GLOBAL VARIABLES
1373
1374 PRIVATE Reads a template, constructing a candidate name for the template thus: $name.$skin.tmpl,
1375 and looking for a file of that name first in templates/$web and then if that fails in templates/.
1376 If a template is not found, tries to parse $name into a web name and a topic name, and
1377 read topic $Web.${Skin}Skin${Topic}Template. If $name does not contain a web specifier,
1378 $Web defaults to TWiki::twikiWebname. If no skin is specified, topic is ${Topic}Template.
1379 If the topic exists, checks access permissions and reads the topic
1380 without meta-data. In the event that the read fails (template not found, access permissions fail)
1381 returns the empty string "". skin, web and topic names are forced to an upper-case first character
1382 when composing user topic names.
1383
1384 =cut
1385
1386 sub _readTemplateFile
1387 rizwank 1.1 {
1388 my( $theName, $theSkin, $theWeb ) = @_;
1389 $theSkin = "" unless $theSkin; # prevent 'uninitialized value' warnings
1390
1391 # CrisBailiff, PeterThoeny 13 Jun 2000: Add security
1392 $theName =~ s/$TWiki::securityFilter//go; # zap anything suspicious
1393 $theName =~ s/\.+/\./g; # Filter out ".." from filename
1394 $theSkin =~ s/$TWiki::securityFilter//go; # zap anything suspicious
1395 $theSkin =~ s/\.+/\./g; # Filter out ".." from filename
1396
1397 my $tmplFile = "";
1398
1399 # search first in twiki/templates/Web dir
1400 # for file script(.skin).tmpl
1401 my $tmplDir = "$TWiki::templateDir/$theWeb";
1402 if( opendir( DIR, $tmplDir ) ) {
1403 # for performance use readdir, not a row of ( -e file )
1404 my @filelist = grep /^$theName\..*tmpl$/, readdir DIR;
1405 closedir DIR;
1406 $tmplFile = "$theName.$theSkin.tmpl";
1407 if( ! grep { /^$tmplFile$/ } @filelist ) {
1408 rizwank 1.1 $tmplFile = "$theName.tmpl";
1409 if( ! grep { /^$tmplFile$/ } @filelist ) {
1410 $tmplFile = "";
1411 }
1412 }
1413 if( $tmplFile ) {
1414 $tmplFile = "$tmplDir/$tmplFile";
1415 }
1416 }
1417
1418 # if not found, search in twiki/templates dir
1419 $tmplDir = $TWiki::templateDir;
1420 if( ( ! $tmplFile ) && ( opendir( DIR, $tmplDir ) ) ) {
1421 my @filelist = grep /^$theName\..*tmpl$/, readdir DIR;
1422 closedir DIR;
1423 $tmplFile = "$theName.$theSkin.tmpl";
1424 if( ! grep { /^$tmplFile$/ } @filelist ) {
1425 $tmplFile = "$theName.tmpl";
1426 if( ! grep { /^$tmplFile$/ } @filelist ) {
1427 $tmplFile = "";
1428 }
1429 rizwank 1.1 }
1430 if( $tmplFile ) {
1431 $tmplFile = "$tmplDir/$tmplFile";
1432 }
1433 }
1434
1435 # See if it is a user topic. Search first in current web
1436 # twiki web. Note that neither web nor topic may be variables when used in a template.
1437 if ( ! $tmplFile ) {
1438 if ( $theSkin ne "" ) {
1439 $theSkin = ucfirst( $theSkin ) . "Skin";
1440 }
1441
1442 my $theTopic;
1443 my $theWeb;
1444
1445 if ( $theName =~ /^(\w+)\.(\w+)$/ ) {
1446 $theWeb = ucfirst( $1 );
1447 $theTopic = ucfirst( $2 );
1448 } else {
1449 $theWeb = $TWiki::webName;
1450 rizwank 1.1 $theTopic = $theSkin . ucfirst( $theName ) . "Template";
1451 if ( !TWiki::Store::topicExists( $theWeb, $theTopic )) {
1452 $theWeb = $TWiki::twikiWebname;
1453 }
1454 }
1455
1456 if ( TWiki::Store::topicExists( $theWeb, $theTopic ) &&
1457 TWiki::Access::checkAccessPermission( "view",
1458 $TWiki::wikiUserName, "", $theTopic, $theWeb )) {
1459 my ( $meta, $text ) = TWiki::Store::readTopic( $theWeb, $theTopic, 1 );
1460 return $text;
1461 }
1462 }
1463
1464 # read the template file
1465 if( -e $tmplFile ) {
1466 return &readFile( $tmplFile );
1467 }
1468 return "";
1469 }
1470
1471 rizwank 1.1 =pod
1472
1473 ---++ sub handleTmplP ( $theVar )
1474 Return value: expanded text of the named template, as found from looking in the global register of template definitions.
1475
1476 WARNING! THIS FUNCTION DEPENDS ON GLOBAL VARIABLES
1477
1478 If $theVar is the name of a previously defined template, returns the text of
1479 that template after recursive expansion of any TMPL:P tags it contains.
1480
1481 =cut
1482
1483 sub handleTmplP
1484 {
1485 # Print template variable, called by %TMPL:P{"$theVar"}%
1486 my( $theVar ) = @_;
1487
1488 my $val = "";
1489 if( ( %templateVars ) && ( exists $templateVars{ $theVar } ) ) {
1490 $val = $templateVars{ $theVar };
1491 $val =~ s/%TMPL\:P{[\s\"]*(.*?)[\"\s]*}%/&handleTmplP($1)/geo; # recursion
1492 rizwank 1.1 }
1493 if( ( $theVar eq "sep" ) && ( ! $val ) ) {
1494 # set separator explicitely if not set
1495 $val = " | ";
1496 }
1497 return $val;
1498 }
1499
1500 =pod
1501
1502 ---++ sub readTemplate ( $theName, $theSkin, $theWeb )
1503 Return value: expanded template text
1504
1505 WARNING! THIS IS A SIDE-EFFECTING FUNCTION
1506
1507 PUBLIC Reads a template, constructing a candidate name for the template as described in
1508 _readTemplateFile.
1509
1510 If template text is found, extracts include statements and fully expands them.
1511 Also extracts template definitions and adds them to the
1512 global templateVars hash, overwriting any previous definition.
1513 rizwank 1.1
1514 =cut
1515
1516 sub readTemplate
1517 {
1518 my( $theName, $theSkin, $theWeb ) = @_;
1519
1520 if( ! defined($theSkin) ) {
1521 $theSkin = &TWiki::getSkin();
1522 }
1523
1524 if( ! defined( $theWeb ) ) {
1525 $theWeb = $TWiki::webName;
1526 }
1527
1528 # recursively read template file(s)
1529 my $text = _readTemplateFile( $theName, $theSkin, $theWeb );
1530 while( $text =~ /%TMPL\:INCLUDE{[\s\"]*(.*?)[\"\s]*}%/s ) {
1531 $text =~ s/%TMPL\:INCLUDE{[\s\"]*(.*?)[\"\s]*}%/&_readTemplateFile( $1, $theSkin, $theWeb )/geo;
1532 }
1533
1534 rizwank 1.1 if( ! ( $text =~ /%TMPL\:/s ) ) {
1535 # no template processing
1536 $text =~ s|^(( {3})+)|"\t" x (length($1)/3)|geom; # leading spaces to tabs
1537 return $text;
1538 }
1539
1540 my $result = "";
1541 my $key = "";
1542 my $val = "";
1543 my $delim = "";
1544 foreach( split( /(%TMPL\:)/, $text ) ) {
1545 if( /^(%TMPL\:)$/ ) {
1546 $delim = $1;
1547 } elsif( ( /^DEF{[\s\"]*(.*?)[\"\s]*}%[\n\r]*(.*)/s ) && ( $1 ) ) {
1548 # handle %TMPL:DEF{"key"}%
1549 if( $key ) {
1550 $templateVars{ $key } = $val;
1551 }
1552 $key = $1;
1553 $val = $2 || "";
1554
1555 rizwank 1.1 } elsif( /^END%[\n\r]*(.*)/s ) {
1556 # handle %TMPL:END%
1557 $templateVars{ $key } = $val;
1558 $key = "";
1559 $val = "";
1560 $result .= $1 || "";
1561
1562 } elsif( $key ) {
1563 $val .= "$delim$_";
1564
1565 } else {
1566 $result .= "$delim$_";
1567 }
1568 }
1569
1570 # handle %TMPL:P{"..."}% recursively
1571 $result =~ s/%TMPL\:P{[\s\"]*(.*?)[\"\s]*}%/&handleTmplP($1)/geo;
1572 $result =~ s|^(( {3})+)|"\t" x (length($1)/3)|geom; # leading spaces to tabs
1573 return $result;
1574 }
1575
1576 rizwank 1.1 =pod
1577
1578 ---++ readFile( $filename )
1579 Return value: $fileContents
1580
1581 Returns the entire contents of the given file, which can be specified in any
1582 format acceptable to the Perl open() function. SECURITY NOTE: make sure
1583 any $filename coming from a user is stripped of special characters that might
1584 change Perl's open() semantics.
1585
1586 =cut
1587
1588 sub readFile
1589 {
1590 my( $name ) = @_;
1591 my $data = "";
1592 undef $/; # set to read to EOF
1593 open( IN_FILE, "<$name" ) || return "";
1594 $data = <IN_FILE>;
1595 $/ = "\n";
1596 close( IN_FILE );
1597 rizwank 1.1 $data = "" unless $data; # no undefined
1598 return $data;
1599 }
1600
1601
1602 =pod
1603
1604 ---++ sub readFileHead ( $name, $maxLines )
1605
1606 Not yet documented.
1607
1608 =cut
1609
1610 sub readFileHead
1611 {
1612 my( $name, $maxLines ) = @_;
1613 my $data = "";
1614 my $line;
1615 my $l = 0;
1616 $/ = "\n"; # read line by line
1617 open( IN_FILE, "<$name" ) || return "";
1618 rizwank 1.1 while( ( $l < $maxLines ) && ( $line = <IN_FILE> ) ) {
1619 $data .= $line;
1620 $l += 1;
1621 }
1622 close( IN_FILE );
1623 return $data;
1624 }
1625
1626
1627 #AS 5 Dec 2000 collect all Web's topic names
1628
1629 =pod
1630
1631 ---+++ getTopicNames( $web ) ==> @topics
1632
1633 | Description: | Get list of all topics in a web |
1634 | Parameter: =$web= | Web name, required, e.g. ="Sandbox"= |
1635 | Return: =@topics= | Topic list, e.g. =( "WebChanges", "WebHome", "WebIndex", "WebNotify" )= |
1636
1637 =cut
1638
1639 rizwank 1.1 sub getTopicNames {
1640 my( $web ) = @_ ;
1641
1642 if( !defined $web ) {
1643 $web="";
1644 }
1645
1646 #FIXME untaint web name?
1647
1648 # get list of all topics by scanning $dataDir
1649 opendir DIR, "$TWiki::dataDir/$web" ;
1650 my @topicList = sort grep { s/\.txt$// } readdir( DIR );
1651 closedir( DIR );
1652 return @topicList ;
1653 }
1654 #/AS
1655
1656
1657 #AS 5 Dec 2000 collect immediate subWeb names
1658
1659 =pod
1660 rizwank 1.1
1661 ---++ sub getSubWebs ( $web )
1662
1663 Not yet documented.
1664
1665 =cut
1666
1667 sub getSubWebs {
1668 my( $web ) = @_ ;
1669
1670 if( !defined $web ) {
1671 $web="";
1672 }
1673
1674 #FIXME untaint web name?
1675
1676 # get list of all subwebs by scanning $dataDir
1677 opendir DIR, "$TWiki::dataDir/$web" ;
1678 my @tmpList = readdir( DIR );
1679 closedir( DIR );
1680
1681 rizwank 1.1 # this is not magic, it just looks like it.
1682 my @webList = sort
1683 grep { s#^.+/([^/]+)$#$1# }
1684 grep { -d }
1685 map { "$TWiki::dataDir/$web/$_" }
1686 grep { ! /^\.\.?$/ } @tmpList;
1687
1688 return @webList ;
1689 }
1690 #/AS
1691
1692
1693 # =========================
1694 #AS 26 Dec 2000 recursively collects all Web names
1695 #FIXME: move var to TWiki.cfg ?
1696 use vars qw ($subWebsAllowedP);
1697
1698 $subWebsAllowedP = 0; # 1 = subwebs allowed, 0 = flat webs
1699
1700 =pod
1701
1702 rizwank 1.1 ---++ sub getAllWebs ( $web )
1703
1704 Not yet documented.
1705
1706 =cut
1707
1708 sub getAllWebs {
1709 # returns a list of subweb names
1710 my( $web ) = @_ ;
1711
1712 if( !defined $web ) {
1713 $web="";
1714 }
1715 my @webList = map { s/^\///o; $_ }
1716 map { "$web/$_" }
1717 &getSubWebs( $web );
1718 my $subWeb = "";
1719 if( $subWebsAllowedP ) {
1720 my @subWebs = @webList;
1721 foreach $subWeb ( @webList ) {
1722 push @subWebs, &getAllWebs( $subWeb );
1723 rizwank 1.1 }
1724 return @subWebs;
1725 }
1726 return @webList ;
1727 }
1728 #/AS
1729
1730 =pod
1731
1732 ---+++ setTopicRevisionTag( $web, $topic, $rev, $tag ) ==> $success
1733
1734 | Description: | sets a names tag on the specified revision |
1735 | Parameter: =$web= | webname |
1736 | Parameter: =$topic= | topic name |
1737 | Parameter: =$rev= | the revision we are taging |
1738 | Parameter: =$tag= | the string to tag with |
1739 | Return: =$success= | |
1740 | TODO: | we _need_ an error mechanism! |
1741 | Since: | TWiki:: (20 April 2004) |
1742
1743 =cut
1744 rizwank 1.1
1745 sub setTopicRevisionTag
1746 {
1747 my ( $web, $topic, $rev, $tag ) = @_;
1748
1749 my $topicHandler = _getTopicHandler( $web, $topic );
1750 # TWiki::writeDebug("Store - setTopicRevisionTag ( $web, $topic, $rev, $tag )");
1751 return $topicHandler->setTopicRevisionTag( $web, $topic, $rev, $tag );
1752 }
1753
1754
1755
1756 # =========================
1757
1758 1;
1759
1760 # EOF
|
Return to
Store.pm
CVS log
Up to [RizwankCVS] / geekymedia_web / twiki / lib / TWiki