1 rizwank 1.1 # Module of TWiki Collaboration Platform, http://TWiki.org/
2 #
3 # Copyright (C) 2002 John Talintyre, john.talintyre@btinternet.com
4 # Copyright (C) 2002-2003 Peter Thoeny, peter@thoeny.com
5 #
6 # For licensing info read license.txt file in the TWiki root.
7 # This program is free software; you can redistribute it and/or
8 # modify it under the terms of the GNU General Public License
9 # as published by the Free Software Foundation; either version 2
10 # of the License, or (at your option) any later version.
11 #
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details, published at
16 # http://www.gnu.org/copyleft/gpl.html
17 #
18 #
19 # Functions used by both Rcs and RcsFile - they both inherit from this Class
20
21 =begin twiki
22 rizwank 1.1
23 ---+ TWiki::Store::RcsFile Module
24
25 This module is contains the shared Rcs code.
26
27 =cut
28
29 package TWiki::Store::RcsFile;
30
31 use strict;
32
33 use File::Copy;
34 use File::Spec;
35
36 # ======================
37 =pod
38
39 ---++ sub new ( $proto, $web, $topic, $attachment, %settings )
40
41 Not yet documented.
42
43 rizwank 1.1 =cut to implementation
44
45 sub new
46 {
47 my( $proto, $web, $topic, $attachment, %settings ) = @_;
48 my $class = ref($proto) || $proto;
49 my $self = {};
50 bless( $self, $class );
51 $self->{"web"} = $web;
52 $self->{"topic"} = $topic;
53 $self->{"attachment"} = $attachment || "";
54 $self->_settings( %settings );
55 $self->{"file"} = $self->_makeFileName();
56 $self->{"rcsFile"} = $self->_makeFileName( ",v" );
57
58 return $self;
59 }
60
61 # ======================
62 =pod
63
64 rizwank 1.1 ---++ sub _init ( $self )
65
66 Not yet documented.
67
68 =cut to implementation
69
70 sub _init
71 {
72 my( $self ) = @_;
73
74 # If attachment - make sure file and history directories exist
75 if( $self->{attachment} ) {
76 # Make sure directory for rcs history file exists
77 my $rcsDir = $self->_makeFileDir( 1, ",v" );
78 my $tempPath = $self->{dataDir} . "/" . $self->{web};
79 if( ! -e "$tempPath" ) {
80 umask( 0 );
81 mkdir( $tempPath, $self->{dirPermission} );
82 }
83 $tempPath = $rcsDir;
84 if( ! -e "$tempPath" ) {
85 rizwank 1.1 umask( 0 );
86 mkdir( $tempPath, $self->{dirPermission} );
87 }
88 }
89
90
91 if( $self->{attachment} &&
92 ! -e $self->{"rcsFile"} &&
93 ! $self->isAsciiDefault() ) {
94 $self->setBinary( 1 );
95 }
96 }
97
98
99 # ======================
100 =pod
101
102 ---++ sub revisionFileExists ( $self )
103
104 Not yet documented.
105
106 rizwank 1.1 =cut to implementation
107
108 sub revisionFileExists
109 {
110 my( $self ) = @_;
111 return ( -e $self->{rcsFile} );
112 }
113
114 # ======================
115 # Psuedo revision information - useful when there is no revision file
116 =pod
117
118 ---++ sub _getRevisionInfoDefault ( $self )
119
120 Not yet documented.
121
122 =cut to implementation
123
124 sub _getRevisionInfoDefault
125 {
126 my( $self ) = @_;
127 rizwank 1.1 my $fileDate = $self->getTimestamp();
128 return ( "", 1, $fileDate, $TWiki::defaultUserName, "Default revision information - no revision file" );
129 }
130
131 # ======================
132 # Get the timestamp of the topic file
133 # Returns 0 if no file, otherwise epoch seconds
134 =pod
135
136 ---++ sub getTimestamp ( $self )
137
138 Not yet documented.
139
140 =cut to implementation
141
142 sub getTimestamp
143 {
144 my( $self ) = @_;
145 my $date = 0;
146 if( -e $self->{file} ) {
147 # Why big number if fail?
148 rizwank 1.1 $date = (stat $self->{file})[9] || 600000000;
149 }
150 return $date;
151 }
152
153
154 # ======================
155 =pod
156
157 ---++ sub restoreLatestRevision ( $self )
158
159 Not yet documented.
160
161 =cut to implementation
162
163 sub restoreLatestRevision
164 {
165 my( $self ) = @_;
166
167 my $rev = $self->numRevisions();
168 my $text = $self->getRevision( $rev );
169 rizwank 1.1 $self->_saveFile( $self->{file}, $text );
170 }
171
172
173 # ======================
174 =pod
175
176 ---++ sub moveMe ( $self, $newWeb, $newTopic, $attachment )
177
178 Not yet documented.
179
180 =cut to implementation
181
182 sub moveMe
183 {
184 my( $self, $newWeb, $newTopic, $attachment ) = @_;
185
186 if( $self->{attachment} ) {
187 $self->_moveAttachment( $newWeb, $newTopic, $self->{attachment} );
188 } else {
189 $self->_moveTopic( $newWeb, $newTopic );
190 rizwank 1.1 }
191 }
192
193
194 # =========================
195 # Move/rename a topic, allow for transfer between Webs
196 # It is the responsibility of the caller to check: exstance webs & topics, lock taken for topic
197 =pod
198
199 ---++ sub _moveTopic ( $self, $newWeb, $newTopic )
200
201 Not yet documented.
202
203 =cut to implementation
204
205 sub _moveTopic
206 {
207 my( $self, $newWeb, $newTopic ) = @_;
208
209 my $oldWeb = $self->{web};
210 my $oldTopic = $self->{topic};
211 rizwank 1.1
212 my $error = "";
213
214 # Change data file
215 my $new = TWiki::Store::RcsFile->new( $newWeb, $newTopic, "",
216 ( pubDir =>$self->{pubDir}, dataDir => $self->{dataDir} ) );
217 my $from = $self->{file};
218 my $to = $new->{file};
219 if( ! move( $from, $to ) ) {
220 $error .= "data file move failed. ";
221 }
222
223 # Change data file history
224 my $oldHistory = $self->{rcsFile};
225 if( ! $error && -e $oldHistory ) {
226 if( ! move(
227 $oldHistory,
228 $new->{rcsFile}
229 ) ) {
230 $error .= "history file move failed. ";
231 }
232 rizwank 1.1 }
233
234 if( ! $error ) {
235 # Make sure pub directory exists for newWeb
236 my $newPubWebDir = $new->_makePubWebDir( $newWeb );
237 if ( ! -e $newPubWebDir ) {
238 umask( 0 );
239 mkdir( $newPubWebDir, $self->{dirPermission} );
240 }
241
242 # Rename the attachment directory if there is one
243 my $oldAttachDir = $self->_makeFileDir( 1, "" );
244 my $newAttachDir = $new->_makeFileDir( 1, "");
245 if( -e $oldAttachDir ) {
246 if( ! move( $oldAttachDir, $newAttachDir ) ) {
247 $error .= "attach move failed";
248 }
249 }
250 }
251
252 return $error;
253 rizwank 1.1 }
254
255
256 # =========================
257 # Move an attachment from one topic to another.
258 # If there is a problem an error string is returned.
259 # The caller to this routine should check that all topics are valid and
260 # do lock on the topics.
261 =pod
262
263 ---++ sub _moveAttachment ( $self, $newWeb, $newTopic )
264
265 Not yet documented.
266
267 =cut to implementation
268
269 sub _moveAttachment
270 {
271 my( $self, $newWeb, $newTopic ) = @_;
272
273 my $oldWeb = $self->{web};
274 rizwank 1.1 my $oldTopic = $self->{topic};
275 my $attachment = $self->{attachment};
276
277 my $error = "";
278 my $what = "$oldWeb.$oldTopic.$attachment -> $newWeb.$newTopic";
279
280 # FIXME might want to delete old directories if empty
281
282 my $new = TWiki::Store::RcsFile->new( $newWeb, $newTopic, $attachment,
283 ( pubDir => $self->{pubDir} ) );
284
285 # before save, create directories if they don't exist
286 my $tempPath = $new->_makePubWebDir();
287 unless( -e $tempPath ) {
288 umask( 0 );
289 mkdir( $tempPath, 0775 );
290 }
291 $tempPath = $new->_makeFileDir( 1 );
292 unless( -e $tempPath ) {
293 umask( 0 );
294 mkdir( $tempPath, 0775 ); # FIXME get from elsewhere
295 rizwank 1.1 }
296
297 # Move attachment
298 my $oldAttachment = $self->{file};
299 my $newAttachment = $new->{file};
300 if( ! move( $oldAttachment, $newAttachment ) ) {
301 $error = "Failed to move attachment; $what ($!)";
302 return $error;
303 }
304
305 # Make sure rcs directory exists
306 my $newRcsDir = $new->_makeFileDir( 1, ",v" );
307 if ( ! -e $newRcsDir ) {
308 umask( 0 );
309 mkdir( $newRcsDir, $self->{dirPermission} );
310 }
311
312 # Move attachment history
313 my $oldAttachmentRcs = $self->{rcsFile};
314 my $newAttachmentRcs = $new->{rcsFile};
315 if( -e $oldAttachmentRcs ) {
316 rizwank 1.1 if( ! move( $oldAttachmentRcs, $newAttachmentRcs ) ) {
317 $error .= "Failed to move attachment history; $what ($!)";
318 # Don't return here as attachment file has already been moved
319 }
320 }
321
322 return $error;
323 }
324
325 # ======================
326 =pod
327
328 ---++ sub _epochToRcsDateTime ( $dateTime )
329
330 Not yet documented.
331
332 =cut to implementation
333
334 sub _epochToRcsDateTime
335 {
336 my( $dateTime ) = @_;
337 rizwank 1.1 # TODO: should this be gmtime or local time?
338 my( $sec,$min,$hour,$mday,$mon,$year,$wday,$yday ) = gmtime( $dateTime );
339 $year += 1900 if( $year > 99 );
340 my $rcsDateTime = sprintf "%d.%02d.%02d.%02d.%02d.%02d", ( $year, $mon + 1, $mday, $hour, $min, $sec );
341 return $rcsDateTime;
342 }
343
344 # ======================
345 # Suitable for rcs format stored in files (and that returned by rcs executables ???)
346 =pod
347
348 ---++ sub _rcsDateTimeToEpoch ( $rcsDate )
349
350 Not yet documented.
351
352 =cut to implementation
353
354 sub _rcsDateTimeToEpoch
355 {
356 my( $rcsDate ) = @_;
357 return TWiki::revDate2EpSecs( $rcsDate );
358 rizwank 1.1 }
359
360 # =========================
361 # Get rid a topic and its attachments completely
362 # Intended for TEST purposes.
363 # Use with GREAT CARE as file will be gone, including RCS history
364 =pod
365
366 ---++ sub _delete ( $self )
367
368 Not yet documented.
369
370 =cut to implementation
371
372 sub _delete
373 {
374 my( $self ) = @_;
375
376 my $web = $self->{web};
377 my $topic = $self->{topic};
378 if( $self->{attachment} ) {
379 rizwank 1.1 $self->delete();
380 return;
381 }
382
383 my $file = $self->{file};
384 my $rcsDirFile = $self->{dataDir} . "/$web/RCS/$topic,v";
385
386 # Because test switches between using/not-using RCS dir, do both
387 my @files = ( $file, "$file,v", $rcsDirFile );
388 unlink( @files );
389
390 # Delete all attachments and the attachment directory
391 my $attDir = $self->_makeFileDir( 1, "" );
392 if( -e $attDir ) {
393 opendir( DIR, $attDir );
394 my @attachments = readdir( DIR );
395 closedir( DIR );
396 my $attachment;
397 foreach $attachment ( @attachments ) {
398 if( ! -d "$attDir/$attachment" ) {
399 unlink( "$attDir/$attachment" ) || warn "Couldn't remove $attDir/$attachment";
400 rizwank 1.1 if( $attachment !~ /,v$/ ) {
401 #writeLog( "erase", "$web.$topic.$attachment" );
402 }
403 }
404 }
405
406 # Deal with RCS dir if it exists
407 my $attRcsDir = "$attDir/RCS";
408 if( -e $attRcsDir ) {
409 opendir( DIR, $attRcsDir );
410 my @attachments = readdir( DIR );
411 closedir( DIR );
412 my $attachment;
413 foreach $attachment ( @attachments ) {
414 if( ! -d "$attRcsDir/$attachment" ) {
415 unlink( "$attRcsDir/$attachment" ) || warn "Couldn't remove $attDir/$attachment";
416 }
417 }
418 rmdir( "$attRcsDir" ) || warn "Couldn't remove directory $attRcsDir";
419 }
420
421 rizwank 1.1 rmdir( "$attDir" ) || warn "Couldn't remove directory $attDir";
422 }
423 }
424
425 # ======================
426 # Delete topic or attachment and history
427 # Main use - unit testing
428 =pod
429
430 ---++ sub delete ( $self )
431
432 Not yet documented.
433
434 =cut to implementation
435
436 sub delete
437 {
438 my( $self ) = @_;
439
440 my $exist = 0;
441 $exist++ if( -f $self->file() );
442 rizwank 1.1 $exist++ if( -f $self->rcsFile() );
443
444 my( @files ) = ( $self->file(), $self->rcsFile() );
445 my $numDeleted = unlink( @files );
446 if( $numDeleted != $exist ) {
447 print "numDeleted = $numDeleted\n"; # TODO: warning
448 }
449
450 $self->_init();
451
452 $self->{"head"} = 0; # TODO move this to RcsLite
453 }
454
455 # ======================
456 =pod
457
458 ---++ sub file ( $self )
459
460 Not yet documented.
461
462 =cut to implementation
463 rizwank 1.1
464 sub file
465 {
466 my( $self ) = @_;
467 return $self->{"file"};
468 }
469
470 # ======================
471 =pod
472
473 ---++ sub rcsFile ( $self )
474
475 Not yet documented.
476
477 =cut to implementation
478
479 sub rcsFile
480 {
481 my( $self ) = @_;
482 return $self->{"rcsFile"};
483 }
484 rizwank 1.1
485 # ======================
486 =pod
487
488 ---++ sub useRcsDir ( $self )
489
490 Not yet documented.
491
492 =cut to implementation
493
494 sub useRcsDir
495 {
496 my( $self ) = @_;
497 return $self->{"useRcsDir"};
498 }
499
500 # ======================
501 =pod
502
503 ---++ sub _settings ( $self, %settings )
504
505 rizwank 1.1 Not yet documented.
506
507 =cut to implementation
508
509 sub _settings
510 {
511 my( $self, %settings ) = @_;
512 $self->{"useRcsDir"} = $settings{"useRcsDir"};
513 $self->{"dataDir"} = $settings{"dataDir"};
514 $self->{"pubDir"} = $settings{"pubDir"};
515 $self->{"binary"} = "";
516 $self->{attachAsciiPath} = $settings{attachAsciiPath};
517 $self->{dirPermission} = $settings{dirPermission};
518 }
519
520 # ======================
521 =pod
522
523 ---++ sub isAsciiDefault ( $self )
524
525 Not yet documented.
526 rizwank 1.1
527 =cut to implementation
528
529 sub isAsciiDefault
530 {
531 my( $self ) = @_;
532
533 my $attachAsciiPath = $self->{"attachAsciiPath"};
534 my $filename = $self->{"attachment"};
535
536 if( $filename =~ /$attachAsciiPath/ ) {
537 return "ascii";
538 } else {
539 return "";
540 }
541 }
542
543 # ======================
544 =pod
545
546 ---++ sub setBinary ( $self, $binary )
547 rizwank 1.1
548 Not yet documented.
549
550 =cut to implementation
551
552 sub setBinary
553 {
554 my( $self, $binary ) = @_;
555 my $oldSetting = $self->{"binary"};
556 $binary = "" if( ! $binary );
557 $self->{"binary"} = $binary;
558 $self->_binaryChange() if( (! $oldSetting && $binary) || ($oldSetting && ! $binary) );
559 }
560
561 # ======================
562 =pod
563
564 ---++ sub getBinary ( $self )
565
566 Not yet documented.
567
568 rizwank 1.1 =cut to implementation
569
570 sub getBinary
571 {
572 my( $self ) = @_;
573 return $self->{"binary"};
574 }
575
576 # ======================
577 =pod
578
579 ---++ sub _warn ( $self, $message )
580
581 Not yet documented.
582
583 =cut to implementation
584
585 sub _warn
586 {
587 my( $self, $message ) = @_;
588 print "Warning: $message\n";
589 rizwank 1.1 }
590
591 # ======================
592 =pod
593
594 ---++ sub setLock ( $self, $lock, $userName )
595
596 Not yet documented.
597
598 =cut to implementation
599
600 sub setLock
601 {
602 my( $self, $lock, $userName ) = @_;
603
604 $userName = $TWiki::userName if( ! $userName );
605
606 my $lockFilename = $self->_makeFileName( ".lock" );
607 if( $lock ) {
608 my $lockTime = time();
609 $self->_saveFile( $lockFilename, "$userName\n$lockTime" );
610 rizwank 1.1 } else {
611 unlink "$lockFilename";
612 }
613 }
614
615 # =========================
616 =pod
617
618 ---++ sub _saveAttachment ( $self, $theTmpFilename )
619
620 Not yet documented.
621
622 =cut to implementation
623
624 sub _saveAttachment
625 {
626 my( $self, $theTmpFilename ) = @_;
627
628 # before save, create directories if they don't exist
629 my $tempPath = $self->_makePubWebDir();
630 if( ! -e "$tempPath" ) {
631 rizwank 1.1 umask( 0 );
632 mkdir( $tempPath, $self->{dirPermission} );
633 }
634 $tempPath = $self->_makeFileDir( 1 );
635 if( ! -e "$tempPath" ) {
636 umask( 0 );
637 mkdir( $tempPath, 0775 );
638 }
639
640 # FIXME share with move - part of init?
641
642 # save uploaded file
643 my $newFile = $self->{file};
644 copy($theTmpFilename, $newFile) or warn "copy($theTmpFilename, $newFile) failed: $!";
645 # FIXME more consistant way of dealing with errors
646 umask( 002 );
647 chmod( 0644, $newFile ); # FIXME config permission for new attachment
648 }
649
650 # ======================
651 # This is really saveTopic
652 rizwank 1.1 =pod
653
654 ---++ sub _saveFile ( $self, $name, $text )
655
656 Not yet documented.
657
658 =cut to implementation
659
660 sub _saveFile
661 {
662 my( $self, $name, $text ) = @_;
663
664 umask( 002 );
665 unless ( open( FILE, ">$name" ) ) {
666 warn "Can't create file $name - $!\n";
667 return;
668 }
669 binmode( FILE );
670 print FILE $text;
671 close( FILE);
672 }
673 rizwank 1.1
674 # ======================
675 # Deal differently with topics and attachments
676 # text is a reference for efficiency
677 =pod
678
679 ---++ sub _save ( $self, $filename, $text )
680
681 Not yet documented.
682
683 =cut to implementation
684
685 sub _save
686 {
687 my( $self, $filename, $text ) = @_;
688
689 if( $self->{attachment} ) {
690 my $tmpFilename = $$text;
691 $self->_saveAttachment( $tmpFilename );
692 } else {
693 $self->_saveFile( $filename, $$text );
694 rizwank 1.1 }
695 }
696
697 # ======================
698 =pod
699
700 ---++ sub _readFile ( $self, $name )
701
702 Not yet documented.
703
704 =cut to implementation
705
706 sub _readFile
707 {
708 my( $self, $name ) = @_;
709 my $data = "";
710 undef $/; # set to read to EOF
711 open( IN_FILE, "<$name" ) || return "";
712 binmode IN_FILE;
713 $data = <IN_FILE>;
714 $/ = "\n";
715 rizwank 1.1 close( IN_FILE );
716 $data = "" unless $data; # no undefined
717 return $data;
718 }
719
720
721 # =========================
722 # Get full filename for attachment or topic, untaint
723 # Extension can be:
724 # If $attachment is blank
725 # blank or .txt - topic data file
726 # ,v - topic history file
727 # lock - topic lock file
728 # If $attachment
729 # blank - attachment file
730 # ,v - attachment history file
731 =pod
732
733 ---++ sub _makeFileName ( $self, $extension )
734
735 Not yet documented.
736 rizwank 1.1
737 =cut to implementation
738
739 sub _makeFileName
740 {
741 my( $self, $extension ) = @_;
742
743 if( ! $extension ) {
744 $extension = "";
745 }
746
747 my $file = "";
748 my $extra = "";
749 my $web = $self->{"web"};
750 my $topic = $self->{"topic"};
751 my $attachment = $self->{"attachment"};
752 my $dataDir = $self->{"dataDir"};
753 my $pubDir = $self->{"pubDir"};
754
755 if( $extension eq ".lock" ) {
756 $file = "$dataDir/$web/$topic$extension";
757 rizwank 1.1
758 } elsif( $attachment ) {
759 if ( $extension eq ",v" && $self->{"useRcsDir"} && -d "$dataDir/$web/RCS" ) {
760 $extra = "/RCS";
761 }
762 $file = "$pubDir/$web/$topic$extra/$attachment$extension";
763
764 } else {
765 if( ! $extension ) {
766 $extension = ".txt";
767 } else {
768 if( $extension eq ",v" ) {
769 $extension = ".txt$extension";
770 if( $self->useRcsDir() && -d "$dataDir/$web/RCS" ) {
771 $extra = "/RCS";
772 }
773 }
774 }
775 $file = "$dataDir/$web$extra/$topic$extension";
776 }
777
778 rizwank 1.1 # FIXME: Dangerous, need to make sure that parameters are not tainted
779 # Shouldn't really need to untaint here - done to be sure
780 $file =~ /(.*)/;
781 $file = $1; # untaint
782
783 return $file;
784 }
785
786 # =========================
787 # Get directory that topic or attachment lives in
788 # Leave topic blank if you want the web directory rather than the topic directory
789 # should simply this with _makeFileName
790 =pod
791
792 ---++ sub _makeFileDir ( $self, $attachment, $extension )
793
794 Not yet documented.
795
796 =cut to implementation
797
798 sub _makeFileDir
799 rizwank 1.1 {
800 my( $self, $attachment, $extension) = @_;
801
802 $extension = "" if( ! $extension );
803
804 my $dataDir = $self->{"dataDir"};
805 my $pubDir = $self->{"pubDir"};
806
807 my $web = $self->{web};
808 my $topic = $self->{topic};
809
810 my $dir = "";
811 if( ! $attachment ) {
812 if( $extension eq ",v" && $self->{"useRcsDir"} && -d "$dataDir/$web/RCS" ) {
813 $dir = "$dataDir/$web/RCS";
814 } else {
815 $dir = "$dataDir/$web";
816 }
817 } else {
818 my $suffix = "";
819 if ( $extension eq ",v" && $self->{"useRcsDir"} && -d "$dataDir/$web/RCS" ) {
820 rizwank 1.1 $suffix = "/RCS";
821 }
822 $dir = "$pubDir/$web/$topic$suffix";
823 }
824
825 # FIXME: Dangerous, need to make sure that parameters are not tainted
826 # Shouldn't really need to untaint here - done to be sure
827 $dir =~ /(.*)/;
828 $dir = $1; # untaint
829
830 return $dir;
831 }
832
833 # ======================
834 =pod
835
836 ---++ sub _makePubWebDir ( $self )
837
838 Not yet documented.
839
840 =cut to implementation
841 rizwank 1.1
842 sub _makePubWebDir
843 {
844 my( $self ) = @_;
845
846 # FIXME: Dangerous, need to make sure that parameters are not tainted
847 my $dir = $self->{pubDir} . "/" . $self->{web};
848 $dir =~ /(.*)/;
849 $dir = $1; # untaint
850
851 return $dir;
852 }
853
854 =pod
855
856 ---++ sub _mkTmpFilename ()
857
858 Not yet documented.
859
860 =cut to implementation
861
862 rizwank 1.1 sub _mkTmpFilename
863 {
864 my $tmpdir = File::Spec->tmpdir();
865 my $file = _mktemp( "twikiAttachmentXXXXXX", $tmpdir );
866 return File::Spec->catfile($tmpdir, $file);
867 }
868
869 # Adapted from CPAN - File::MkTemp
870 =pod
871
872 ---++ sub _mktemp ( $template,$dir,$ext,$keepgen,$lookup )
873
874 Not yet documented.
875
876 =cut to implementation
877
878 sub _mktemp {
879 my ($template,$dir,$ext,$keepgen,$lookup);
880 my (@template,@letters);
881
882 croak("Usage: mktemp('templateXXXXXX',['/dir'],['ext']) ")
883 rizwank 1.1 unless(@_ == 1 || @_ == 2 || @_ == 3);
884
885 ($template,$dir,$ext) = @_;
886 @template = split //, $template;
887
888 croak("The template must end with at least 6 uppercase letter X")
889 if (substr($template, -6, 6) ne 'XXXXXX');
890
891 if ($dir){
892 croak("The directory in which you wish to test for duplicates, $dir, does not exist") unless (-e $dir);
893 }
894
895 @letters = split(//,"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ");
896
897 $keepgen = 1;
898
899 while ($keepgen){
900 for (my $i = $#template; $i >= 0 && ($template[$i] eq 'X'); $i--){
901 $template[$i] = $letters[int(rand 52)];
902 }
903
904 rizwank 1.1 undef $template;
905
906 $template = pack "a" x @template, @template;
907
908 $template = $template . $ext if ($ext);
909
910 if ($dir){
911 $lookup = File::Spec->catfile($dir, $template);
912 $keepgen = 0 unless (-e $lookup);
913 }else{
914 $keepgen = 0;
915 }
916
917 next if $keepgen == 0;
918 }
919
920 return($template);
921 }
922
923 1;
|
Return to
RcsFile.pm
CVS log
Up to [RizwankCVS] / geekymedia_web / twiki / lib / TWiki / Store