1 rizwank 1.1 # Module of TWiki Collaboration Platform, http://TWiki.org/
2 #
3 # Copyright (C) 2002 John Talintyre, john.talintyre@btinternet.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 #
18 # Functions used by both Rcs and RcsFile - they both inherit from this Class
19 #
20 # Simple interface to RCS. Doesn't support:
21 # branches
22 rizwank 1.1 # locking
23 #
24 # This modules doesn't know anything about the content of the topic e.g. it doesn't know
25 # about the meta data.
26 #
27 # FIXME:
28 # - need to tidy up dealing with \n for differences
29 # - still have difficulty on line ending at end of sequences, consequence of doing a line based diff
30 # - most serious is when having multiple line ends on one seq but not other - this needs fixing
31 # - tidyup us of 1. for revisions
32 # - cleaner dealing with errors/warnings
33
34 =begin twiki
35
36 ---+ TWiki::Store::RcsLite Module
37
38 This module implements rcs (without calling it)
39
40 =cut
41
42 package TWiki::Store::RcsLite;
43 rizwank 1.1
44 use TWiki::Store::RcsFile;
45 @ISA = qw(TWiki::Store::RcsFile);
46
47 use strict;
48 #use Algorithm::Diff;# qw(diff sdiff);
49 use Algorithm::Diff;
50 use FileHandle;
51 use TWiki;
52
53 TWiki::writeDebug("Diff version $Algorithm::Diff::VERSION\n");
54
55 my $DIFF_DEBUG = 0;
56 my $DIFFEND_DEBUG = 0;
57
58 # ======================
59 =pod
60
61 ---++ sub new ( $proto, $web, $topic, $attachment, %settings )
62
63 Not yet documented.
64 rizwank 1.1
65 =cut to implementation
66
67 sub new
68 {
69 my( $proto, $web, $topic, $attachment, %settings ) = @_;
70 my $class = ref($proto) || $proto;
71 my $self = TWiki::Store::RcsFile->new( $web, $topic, $attachment, %settings );
72 bless( $self, $class );
73 $self->_init();
74 $self->{head} = 0;
75 return $self;
76 }
77
78 # ======================
79 =pod
80
81 ---++ sub _trace ()
82
83 Not yet documented.
84
85 rizwank 1.1 =cut to implementation
86
87 sub _trace
88 {
89 # my( $text ) = @_;
90 # TWiki::writeDebug( "RcsLite $text" );
91 }
92
93
94 # Process an RCS file
95
96 # File format information:
97 #
98 #rcstext ::= admin {delta}* desc {deltatext}*
99 #admin ::= head {num};
100 # { branch {num}; }
101 # access {id}*;
102 # symbols {sym : num}*;
103 # locks {id : num}*; {strict ;}
104 # { comment {string}; }
105 # { expand {string}; }
106 rizwank 1.1 # { newphrase }*
107 #delta ::= num
108 # date num;
109 # author id;
110 # state {id};
111 # branches {num}*;
112 # next {num};
113 # { newphrase }*
114 #desc ::= desc string
115 #deltatext ::= num
116 # log string
117 # { newphrase }*
118 # text string
119 #num ::= {digit | .}+
120 #digit ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
121 #id ::= {num} idchar {idchar | num }*
122 #sym ::= {digit}* idchar {idchar | digit }*
123 #idchar ::= any visible graphic character except special
124 #special ::= $ | , | . | : | ; | @
125 #string ::= @{any character, with @ doubled}*@
126 #newphrase ::= id word* ;
127 rizwank 1.1 #word ::= id | num | string | :
128 #
129 # Identifiers are case sensitive. Keywords are in lower case only. The sets of keywords and
130 # identifiers can overlap. In most environments RCS uses the ISO 8859/1 encoding:
131 # visible graphic characters are codes 041-176 and 240-377, and white space characters are
132 # codes 010-015 and 040.
133 #
134 # Dates, which appear after the date keyword, are of the form Y.mm.dd.hh.mm.ss,
135 # where Y is the year, mm the month (01-12), dd the day (01-31), hh the hour (00-23),
136 # mm the minute (00-59), and ss the second (00-60). Y contains just the last two digits of
137 # the year for years from 1900 through 1999, and all the digits of years thereafter.
138 # Dates use the Gregorian calendar; times use UTC.
139 #
140 # The newphrase productions in the grammar are reserved for future extensions to the format
141 # of RCS files. No newphrase will begin with any keyword already in use.
142
143 # ======================
144 =pod
145
146 ---++ sub _readTo ( $file, $char )
147
148 rizwank 1.1 Not yet documented.
149
150 =cut to implementation
151
152 sub _readTo
153 {
154 my( $file, $char ) = @_;
155 my $buf = "";
156 my $ch;
157 my $space = 0;
158 my $string = "";
159 my $state = "";
160 while( read( $file, $ch, 1 ) ) {
161 if( $ch eq "@" ) {
162 if( $state eq "@" ) {
163 $state = "e";
164 next;
165 } elsif( $state eq "e" ) {
166 $state = "@";
167 $string .= "@";
168 next;
169 rizwank 1.1 } else {
170 $state = "@";
171 next;
172 }
173 } else {
174 if( $state eq "e" ) {
175 $state = "";
176 if( $char eq "@" ) {
177 last;
178 }
179 # End of string
180 } elsif ( $state eq "@" ) {
181 $string .= $ch;
182 next;
183 }
184 }
185
186 if( $ch =~ /\s/ ) {
187 if( length( $buf ) == 0 ) {
188 next;
189 } elsif( $space ) {
190 rizwank 1.1 next;
191 } else {
192 $space = 1;
193 $ch = " ";
194 }
195 } else {
196 $space = 0;
197 }
198 $buf .= $ch;
199 if( $ch eq $char ) {
200 last;
201 }
202 }
203 return( $buf, $string );
204 }
205
206 # ======================
207 # Called by routines that must make sure RCS file has been read in
208 =pod
209
210 ---++ sub _ensureProcessed ( $self )
211 rizwank 1.1
212 Not yet documented.
213
214 =cut to implementation
215
216 sub _ensureProcessed
217 {
218 my( $self ) = @_;
219 if( ! $self->{where} ) {
220 $self->_process();
221 }
222 }
223
224 # ======================
225 # Read in the whole RCS file
226 =pod
227
228 ---++ sub _process ( $self )
229
230 Not yet documented.
231
232 rizwank 1.1 =cut to implementation
233
234 sub _process
235 {
236 my( $self ) = @_;
237 my $rcsFile = $self->rcsFile();
238 if( ! -e $rcsFile ) {
239 $self->{where} = "nofile";
240 return;
241 }
242 my $fh = new FileHandle;
243 if( ! $fh->open( $rcsFile ) ) {
244 $self->_warn( "Couldn't open file $rcsFile" );
245 $self->{where} = "nofile";
246 return;
247 }
248 my $where = "admin.head";
249 binmode( $fh );
250 my $lastWhere = "";
251 my $going = 1;
252 my $term = ";";
253 rizwank 1.1 my $string = "";
254 my $num = "";
255 my $headNum = "";
256 my @date = ();
257 my @author = ();
258 my @log = ();
259 my @text = ();
260 my $dnum = "";
261 while( $going ) {
262 ($_, $string) = _readTo( $fh, $term );
263 last if( ! $_ );
264
265 my $lastWhere = $where;
266 #print "\"$where -- $_\"\n";
267 if( $where eq "admin.head" ) {
268 if( /^head\s+([0-9]+)\.([0-9]+);$/o ) {
269 die( "Only support start of version being 1" ) if( $1 ne "1" );
270 $headNum = $2;
271 $where = "admin.access"; # Don't support branch
272 } else {
273 last;
274 rizwank 1.1 }
275 } elsif( $where eq "admin.access" ) {
276 if( /^access\s*(.*);$/o ) {
277 $where = "admin.symbols";
278 $self->{access} = $1;
279 } else {
280 last;
281 }
282 } elsif( $where eq "admin.symbols" ) {
283 if( /^symbols(.*);$/o ) {
284 $where = "admin.locks";
285 $self->{symbols} = $1;
286 } else {
287 last;
288 }
289 } elsif( $where eq "admin.locks" ) {
290 if( /^locks.*;$/o ) {
291 $where = "admin.postLocks";
292 } else {
293 last;
294 }
295 rizwank 1.1 } elsif( $where eq "admin.postLocks" ) {
296 if( /^strict\s*;/o ) {
297 $where = "admin.postStrict";
298 }
299 } elsif( $where eq "admin.postStrict" &&
300 /^comment\s.*$/o ) {
301 $where = "admin.postComment";
302 $self->{comment} = $string;
303 } elsif( ( $where eq "admin.postStrict" || $where eq "admin.postComment" ) &&
304 /^expand\s/o ) {
305 $where = "admin.postExpand";
306 $self->{expand} = $string;
307 } elsif( $where eq "admin.postStrict" || $where eq "admin.postComment" ||
308 $where eq "admin.postExpand" || $where eq "delta.date") {
309 if( /^([0-9]+)\.([0-9]+)\s+date\s+(\d\d(\d\d)?(\.\d\d){5}?);$/o ) {
310 $where = "delta.author";
311 $num = $2;
312 $date[$num] = TWiki::Store::RcsFile::_rcsDateTimeToEpoch ($3 );
313 }
314 } elsif( $where eq "delta.author" ) {
315 if( /^author\s+(.*);$/o ) {
316 rizwank 1.1 $author[$num] = $1;
317 if( $num == 1 ) {
318 $where = "desc";
319 $term = "@";
320 } else {
321 $where = "delta.date";
322 }
323 }
324 } elsif( $where eq "desc" ) {
325 if( /desc\s*$/o ) {
326 $self->{"description"} = $string;
327 $where = "deltatext.log";
328 }
329 } elsif( $where eq "deltatext.log" ) {
330 if( /\d+\.(\d+)\s+log\s+$/o ) {
331 $dnum = $1;
332 $log[$dnum] = $string;
333 $where = "deltatext.text";
334 }
335 } elsif( $where eq "deltatext.text" ) {
336 if( /text\s*$/o ) {
337 rizwank 1.1 $where = "deltatext.log";
338 $text[$dnum] = $string;
339 if( $dnum == 1 ) {
340 $where = "done";
341 last;
342 }
343 }
344 }
345 }
346
347 $self->{"head"} = $headNum;
348 $self->{"author"} = \@author;
349 $self->{"date"} = \@date; #TODO: i hitnk i need to make this into epochSecs
350 $self->{"log"} = \@log;
351 $self->{"delta"} = \@text;
352 $self->{"status"} = $dnum;
353 $self->{where} = $where;
354
355 close( $fh );
356 }
357
358 rizwank 1.1 # ======================
359 =pod
360
361 ---++ sub _formatString ( $str )
362
363 Not yet documented.
364
365 =cut to implementation
366
367 sub _formatString
368 {
369 my( $str ) = @_;
370 $str =~ s/@/@@/go;
371 return "\@$str\@";
372 }
373
374 # ======================
375 # Write content of the RCS file
376 =pod
377
378 ---++ sub _write ( $self, $file )
379 rizwank 1.1
380 Not yet documented.
381
382 =cut to implementation
383
384 sub _write
385 {
386 my( $self, $file ) = @_;
387
388 # admin
389 print $file "head\t1." . $self->numRevisions() . ";\n";
390 print $file "access" . $self->access() . ";\n";
391 print $file "symbols" . $self->{symbols} . ";\n";
392 print $file "locks; strict;\n";
393 printf $file "comment\t%s;\n", ( _formatString( $self->comment() ) );
394 printf $file "expand\t@%s@;\n", ( $self->{expand} ) if ( $self->{expand} );
395
396 print $file "\n";
397
398 # delta
399 for( my $i=$self->numRevisions(); $i>0; $i--) {
400 rizwank 1.1 printf $file "\n1.%d\ndate\t%s;\tauthor %s;\tstate Exp;\nbranches;\n",
401 ($i, TWiki::Store::RcsFile::_epochToRcsDateTime( ${$self->{date}}[$i] ), $self->author($i) );
402 if( $i == 1 ) {
403 print $file "next\t;\n";
404 } else {
405 printf $file "next\t1.%d;\n", ($i - 1);
406 }
407 }
408
409 printf $file "\n\ndesc\n%s\n\n", ( _formatString( $self->description() ) );
410
411 for( my $i=$self->numRevisions(); $i>0; $i--) {
412 printf $file "\n1.$i\nlog\n%s\ntext\n%s\n",
413 ( _formatString( $self->log($i) ), _formatString( $self->delta($i) ) );
414 }
415 }
416
417 # ======================
418 =pod
419
420 ---++ sub _binaryChange ( $self )
421 rizwank 1.1
422 Not yet documented.
423
424 =cut to implementation
425
426 sub _binaryChange
427 {
428 my( $self ) = @_;
429 # Nothing to be done but note for re-writing
430 $self->{expand} = "b" if( $self->{binary} );
431 # FIXME: unless we have to not do diffs for binary files
432 }
433
434 # ======================
435 =pod
436
437 ---++ sub numRevisions ( $self )
438
439 Not yet documented.
440
441 =cut to implementation
442 rizwank 1.1
443 sub numRevisions
444 {
445 my( $self ) = @_;
446 $self->_ensureProcessed();
447 return $self->{"head"};
448 }
449
450 # ======================
451 =pod
452
453 ---++ sub access ( $self )
454
455 Not yet documented.
456
457 =cut to implementation
458
459 sub access
460 {
461 my( $self ) = @_;
462 $self->_ensureProcessed();
463 rizwank 1.1 return $self->{access};
464 }
465
466 # ======================
467 =pod
468
469 ---++ sub comment ( $self )
470
471 Not yet documented.
472
473 =cut to implementation
474
475 sub comment
476 {
477 my( $self ) = @_;
478 $self->_ensureProcessed();
479 return $self->{"comment"};
480 }
481
482 # ======================
483 =pod
484 rizwank 1.1
485 ---++ sub date ( $self, $version )
486
487 Not yet documented.
488 | $date | in epoch seconds |
489
490 =cut to implementation
491
492 sub date
493 {
494 my( $self, $version ) = @_;
495 $self->_ensureProcessed();
496 my $date = ${$self->{"date"}}[$version];
497 if( $date ) {
498 # $date = TWiki::Store::RcsFile::_rcsDateTimeToEpoch( $date );
499 } else {
500 $date = 0;#MMMM, should this be 0, or now()?
501 }
502 return $date;
503 }
504
505 rizwank 1.1 # ======================
506 =pod
507
508 ---++ sub description ( $self )
509
510 Not yet documented.
511
512 =cut to implementation
513
514 sub description
515 {
516 my( $self ) = @_;
517 $self->_ensureProcessed();
518 return $self->{"description"};
519 }
520
521 # ======================
522 =pod
523
524 ---++ sub author ( $self, $version )
525
526 rizwank 1.1 Not yet documented.
527
528 =cut to implementation
529
530 sub author
531 {
532 my( $self, $version ) = @_;
533 $self->_ensureProcessed();
534 return ${$self->{"author"}}[$version];
535 }
536
537 # ======================
538 =pod
539
540 ---++ sub log ( $self, $version )
541
542 Not yet documented.
543
544 =cut to implementation
545
546 sub log
547 rizwank 1.1 {
548 my( $self, $version ) = @_;
549 $self->_ensureProcessed();
550 return ${$self->{"log"}}[$version];
551 }
552
553 # ======================
554 =pod
555
556 ---++ sub delta ( $self, $version )
557
558 Not yet documented.
559
560 =cut to implementation
561
562 sub delta
563 {
564 my( $self, $version ) = @_;
565 $self->_ensureProcessed();
566 return ${$self->{"delta"}}[$version];
567 }
568 rizwank 1.1
569 # ======================
570 =pod
571
572 ---++ sub addRevision ( $self, $text, $log, $author, $date )
573
574 Not yet documented.
575 | $date | in epoch seconds |
576
577 =cut to implementation
578
579 sub addRevision
580 {
581 my( $self, $text, $log, $author, $date ) = @_;
582 _trace( "::addRevision date=\"$date\"" );
583 $self->_ensureProcessed();
584
585 $self->_save( $self->file(), \$text );
586 $text = $self->_readFile( $self->{file} ) if( $self->{attachment} );
587 my $head = $self->numRevisions();
588 if( $head ) {
589 rizwank 1.1 my $delta = _diffText( \$text, \$self->delta($head), "", 0 );
590 ${$self->{"delta"}}[$head] = $delta;
591 }
592 $head++;
593 ${$self->{"delta"}}[$head] = $text;
594 $self->{"head"} = $head;
595 ${$self->{"log"}}[$head] = $log;
596 ${$self->{"author"}}[$head] = $author;
597 if( $date ) {
598 # $date =~ s/[ \/\:]/\./go;
599 } else {
600 $date = time();
601 }
602 # $date = TWiki::Store::RcsFile::_epochToRcsDateTime( $date );
603
604
605 _trace("::addRevision date now=\"$date\"" );
606 ${$self->{"date"}}[$head] = $date;
607
608 return $self->_writeMe();
609 }
610 rizwank 1.1
611 # ======================
612 =pod
613
614 ---++ sub _writeMe ( $self )
615
616 Not yet documented.
617
618 =cut to implementation
619
620 sub _writeMe
621 {
622 my( $self ) = @_;
623 my $dataError = "";
624 my $out = new FileHandle;
625
626 chmod( 0644, $self->rcsFile() ); # FIXME move permission to config or similar
627 if( ! $out->open( "> " . $self->rcsFile() ) ) {
628 $dataError = "Problem opening " . $self->rcsFile() . " for writing";
629 } else {
630 binmode( $out );
631 rizwank 1.1 $self->_write( $out );
632 close( $out );
633 }
634 chmod( 0444, $self->rcsFile() ); # FIXME as above
635 return $dataError;
636 }
637
638 # ======================
639 =pod
640
641 ---++ sub replaceRevision ( $self, $text, $comment, $user, $date )
642
643 Not yet documented.
644 # Replace the top revision
645 # Return non empty string with error message if there is a problem
646 | $date | is on epoch seconds |
647
648 =cut to implementation
649
650 sub replaceRevision
651 {
652 rizwank 1.1 my( $self, $text, $comment, $user, $date ) = @_;
653 _trace( "::replaceRevision date=\"$date\"" );
654 $self->_ensureProcessed();
655 $self->_delLastRevision();
656 $self->addRevision( $text, $comment, $user, $date );
657 }
658
659 # ======================
660 # Delete the last revision - do nothing if there is only one revision
661 =pod
662
663 ---++ sub deleteRevision ( $self )
664
665 Not yet documented.
666
667 =cut to implementation
668
669 sub deleteRevision
670 {
671 my( $self ) = @_;
672 $self->_ensureProcessed();
673 rizwank 1.1 return "" if( $self->numRevisions() <= 1 );
674 $self->_delLastRevision();
675 return $self->_writeMe();
676 }
677
678 # ======================
679 =pod
680
681 ---++ sub _delLastRevision ( $self )
682
683 Not yet documented.
684
685 =cut to implementation
686
687 sub _delLastRevision
688 {
689 my( $self ) = @_;
690 my $numRevisions = $self->numRevisions();
691 if( $numRevisions > 1 ) {
692 # Need to recover text for last revision
693 my $lastText = $self->getRevision( $numRevisions - 1 );
694 rizwank 1.1 $numRevisions--;
695 $self->{"delta"}->[$numRevisions] = $lastText;
696 } else {
697 $numRevisions--;
698 }
699 $self->{head} = $numRevisions;
700 }
701
702 # ======================
703 =pod
704
705 ---++ sub revisionDiff ( $self, $rev1, $rev2, $contextLines )
706
707 Not yet documented.
708 | TODO: | so why does this read the rcs file, re-create each of the 2 revisions and then diff them? isn't the delta in the rcs file good enough? (until you want context?) |
709 =cut to implementation
710
711 sub revisionDiff
712 {
713 my( $self, $rev1, $rev2, $contextLines ) = @_;
714 $self->_ensureProcessed();
715 rizwank 1.1 my $text1 = $self->getRevision( $rev1 );
716 my $text2 = $self->getRevision( $rev2 );
717
718 my @lNew = _mySplit( \$text1 );
719 my @lOld = _mySplit( \$text2 );
720 my $diff = Algorithm::Diff::sdiff( \@lNew, \@lOld );
721
722 #the Diff::sdiff algol seems to work better with \n, and the rendering currently needs no \n's
723 my @list;
724 foreach my $ele ( @$diff ) {
725 @$ele[1] =~ s/\n//go;
726 @$ele[2] =~ s/\n//go;
727 push @list, $ele;
728 }
729 return ("", \@list);
730 }
731
732
733 =pod
734
735 ---+++ setTopicRevisionTag( $web, $topic, $rev, $tag ) ==> $success
736 rizwank 1.1
737 | Description: | sets a names tag on the specified revision |
738 | Parameter: =$web= | webname |
739 | Parameter: =$topic= | topic name |
740 | Parameter: =$rev= | the revision we are taging |
741 | Parameter: =$tag= | the string to tag with |
742 | Return: =$success= | |
743 | TODO: | we _need_ an error mechanism! |
744 | Since: | TWiki:: (20 April 2004) |
745
746 =cut
747
748 sub setTopicRevisionTag
749 {
750 # my ( $self, $web, $topic, $rev, $tag ) = @_;
751
752 TWiki::writeDebug("setTopicRevisionTag - not implemented in RCSLite");
753 #TODO: implement me :)
754
755 return "";
756 }
757 rizwank 1.1
758
759 # ======================
760 =pod
761
762 ---++ sub getRevision ( $self, $version )
763
764 Not yet documented.
765
766 =cut to implementation
767
768 sub getRevision
769 {
770 my( $self, $version ) = @_;
771 $self->_ensureProcessed();
772 my $head = $self->numRevisions();
773 if( $version == $head ) {
774 return $self->delta( $version );
775 } else {
776 my $headText = $self->delta( $head );
777 my @text = _mySplit( \$headText, 1 );
778 rizwank 1.1 return $self->_patchN( \@text, $head-1, $version );
779 }
780 }
781
782 # ======================
783 # If revision file is missing, information based on actual file is returned.
784 # Date is in epoch based seconds
785 =pod
786
787 ---++ sub getRevisionInfo ( $self, $version )
788
789 Not yet documented.
790
791 =cut to implementation
792
793 sub getRevisionInfo
794 {
795 my( $self, $version ) = @_;
796 $self->_ensureProcessed();
797 $version = $self->numRevisions() if( ! $version );
798
799 rizwank 1.1 #TODO: need to add a where $revision is not number, find out what rev number the tag refers to
800
801 my @result;
802
803 if( $self->{where} && $self->{where} ne "nofile" ) {
804 @result = ( "", $version, $self->date( $version ), $self->author( $version ), $self->comment( $version ) );
805 } else {
806 @result = $self->_getRevisionInfoDefault();
807 }
808
809 return @result;
810 }
811
812
813 # ======================
814 # Apply delta (patch) to text. Note that RCS stores reverse deltas, the is text for revision x
815 # is patched to produce text for revision x-1.
816 # It is fiddly dealing with differences in number of line breaks after the end of the
817 # text.
818 =pod
819
820 rizwank 1.1 ---++ sub _patch ( $text, $delta )
821
822 Not yet documented.
823
824 =cut to implementation
825
826 sub _patch
827 {
828 # Both params are references to arrays
829 my( $text, $delta ) = @_;
830 my $adj = 0;
831 my $pos = 0;
832 my $last = "";
833 my $d;
834 my $extra = "";
835 my $max = $#$delta;
836 while( $pos <= $max ) {
837 $d = $delta->[$pos];
838 if( $d =~ /^([ad])(\d+)\s(\d+)\n(\n*)/ ) {
839 $last = $1;
840 $extra = $4;
841 rizwank 1.1 my $offset = $2;
842 my $length = $3;
843 if( $last eq "d" ) {
844 my $start = $offset + $adj - 1;
845 my @removed = splice( @$text, $start, $length );
846 $adj -= $length;
847 $pos++;
848 } elsif( $last eq "a" ) {
849 my @toAdd = @$delta[$pos+1..$pos+$length];
850 if( $extra ) {
851 if( @toAdd ) {
852 $toAdd[$#toAdd] .= $extra;
853 } else {
854 @toAdd = ( $extra );
855 }
856 }
857 splice( @$text, $offset + $adj, 0, @toAdd );
858 $adj += $length;
859 $pos += $length + 1;
860 }
861 } else {
862 rizwank 1.1 warn( "wrong! - should be \"[ad]<num> <num>\" and was: \"" . $d . "\"\n\n" ); #FIXME remove die
863 return;
864 }
865 }
866 }
867
868
869 # ======================
870 =pod
871
872 ---++ sub _patchN ( $self, $text, $version, $target )
873
874 Not yet documented.
875
876 =cut to implementation
877
878 sub _patchN
879 {
880 my( $self, $text, $version, $target ) = @_;
881
882 my $deltaText= $self->delta( $version );
883 rizwank 1.1 my @delta = _mySplit( \$deltaText );
884 _patch( $text, \@delta );
885 if( $version <= $target ) {
886 return join( "", @$text );
887 } else {
888 return $self->_patchN( $text, $version-1, $target );
889 }
890 }
891
892 # ======================
893 # Split and make sure we have trailing carriage returns
894 =pod
895
896 ---++ sub _mySplit ( $text, $addEntries )
897
898 Not yet documented.
899
900 =cut to implementation
901
902 sub _mySplit
903 {
904 rizwank 1.1 my( $text, $addEntries ) = @_;
905
906 my $ending = "";
907 if( $$text =~ /(\n+)$/o ) {
908 $ending = $1;
909 }
910
911 my @list = split( /\n/o, $$text );
912 for( my $i = 0; $i<$#list; $i++ ) {
913 $list[$i] .= "\n";
914 }
915
916 if( $ending ) {
917 if( $addEntries ) {
918 my $len = length($ending);
919 if( @list ) {
920 $len--;
921 $list[$#list] .= "\n";
922 }
923 for( my $i=0; $i<$len; $i++ ) {
924 push @list, ("\n");
925 rizwank 1.1 }
926 } else {
927 if( @list ) {
928 $list[$#list] .= $ending;
929 } else {
930 @list = ( $ending );
931 }
932 }
933 }
934 # TODO: deal with Mac style line ending??
935
936 return @list; # FIXME would it be more efficient to return a reference?
937 }
938
939 # ======================
940 # Way of dealing with trailing \ns feels clumsy
941 =pod
942
943 ---++ sub _diffText ( $new, $old, $type, $contextLines )
944
945 Not yet documented.
946 rizwank 1.1
947 =cut to implementation
948
949 sub _diffText
950 {
951 my( $new, $old, $type, $contextLines ) = @_;
952
953 my @lNew = _mySplit( $new );
954 my @lOld = _mySplit( $old );
955 return _diff( \@lNew, \@lOld, $type, $contextLines );
956 }
957
958 # ======================
959 =pod
960
961 ---++ sub _lastNoEmptyItem ( $items )
962
963 Not yet documented.
964
965 =cut to implementation
966
967 rizwank 1.1 sub _lastNoEmptyItem
968 {
969 my( $items ) = @_;
970 my $pos = $#$items;
971 my $count = 0;
972 my $item;
973 while( $pos >= 0 ) {
974 $item = $items->[$pos];
975 last if( $item );
976 $count++;
977 $pos--;
978 }
979 return( $pos, $count );
980 }
981
982 # ======================
983 # Deal with trailing carriage returns - Algorithm doesn't give output that RCS format is too happy with
984 =pod
985
986 ---++ sub _diffEnd ( $new, $old, $type )
987
988 rizwank 1.1 Not yet documented.
989
990 =cut to implementation
991
992 sub _diffEnd
993 {
994 my( $new, $old, $type ) = @_;
995 return if( $type ); # FIXME
996
997 my( $posNew, $countNew ) = _lastNoEmptyItem( $new );
998 my( $posOld, $countOld ) = _lastNoEmptyItem( $old );
999
1000 return "" if( $countNew == $countOld );
1001
1002 if( $DIFFEND_DEBUG ) {
1003 print( "countOld, countNew, posOld, posNew, lastOld, lastNew, lenOld: " .
1004 "$countOld, $countNew, $posOld, $posNew, " . $#$old . ", " . $#$new .
1005 "," . @$old . "\n" );
1006 }
1007
1008 $posNew++;
1009 rizwank 1.1 my $toDel = ( $countNew < 2 ) ? 1 : $countNew;
1010 my $startA = @$new - ( ( $countNew > 0 ) ? 1 : 0 );
1011 my $toAdd = ( $countOld < 2 ) ? 1 : $countOld;
1012 my $theEnd = "d$posNew $toDel\na$startA $toAdd\n";
1013 for( my $i=$posOld; $i<@${old}; $i++ ) {
1014 $theEnd .= $old->[$i] ? $old->[$i] : "\n";
1015 }
1016
1017 for( my $i=0; $i<$countNew; $i++ ) {pop @$new;}
1018 pop @$new;
1019 for( my $i=0; $i<$countOld; $i++ ) {pop @$old;}
1020 pop @$old;
1021
1022 print "--$theEnd--\n" if( $DIFFEND_DEBUG );
1023
1024 return $theEnd;
1025 }
1026
1027 # ======================
1028 # no type means diff for putting in rcs file, diff means normal diff output
1029 =pod
1030 rizwank 1.1
1031 ---++ sub _diff ( $new, $old, $type, $contextLines )
1032
1033 Not yet documented.
1034
1035 TODO need to add functionality to use $contextLines
1036
1037 =cut to implementation
1038
1039 sub _diff
1040 {
1041 my( $new, $old, $type, $contextLines ) = @_;
1042 # Work out diffs to change new to old, params are refs to lists
1043 my $diffs = Algorithm::Diff::diff( $new, $old );
1044
1045 my $adj = 0;
1046 my @patch = ();
1047 my @del = ();
1048 my @ins = ();
1049 my $out = "";
1050 my $start = 0;
1051 rizwank 1.1 my $start1;
1052 my $chunkSign = "";
1053 my $count = 0;
1054 my $numChunks = @$diffs;
1055 my $last = 0;
1056 my $lengthNew = @$new - 1;
1057 foreach my $chunk ( @$diffs ) {
1058 $count++;
1059 print "[\n" if( $DIFF_DEBUG );
1060 $chunkSign = "";
1061 my @lines = ();
1062 foreach my $line ( @$chunk ) {
1063 my( $sign, $pos, $what ) = @$line;
1064 print "$sign $pos \"$what\"\n" if( $DIFF_DEBUG );
1065 if( $chunkSign ne $sign && $chunkSign ne "") {
1066 if( $chunkSign eq "-" && $type eq "diff" ) {
1067 # Might be change of lines
1068 my $chunkLength = @$chunk;
1069 my $linesSoFar = @lines;
1070 if( $chunkLength == 2 * $linesSoFar ) {
1071 $chunkSign = "c";
1072 rizwank 1.1 $start1 = $pos;
1073 }
1074 }
1075 $adj += _addChunk( $chunkSign, \$out, \@lines, $start, $adj, $type, $start1, $last ) if( $chunkSign ne "c" );
1076 }
1077 if( ! @lines ) {
1078 $start = $pos;
1079 }
1080 $chunkSign = $sign if( $chunkSign ne "c" );
1081 push @lines, ( $what );
1082 }
1083
1084 $last = 1 if( $count == $numChunks );
1085 if( $last && $chunkSign eq "+" ) {
1086 my $endings = 0;
1087 for( my $i=$#$old; $i>=0; $i-- ) {
1088 if( $old->[$i] ) {
1089 last;
1090 } else {
1091 $endings++;
1092 }
1093 rizwank 1.1 }
1094 my $has = 0;
1095 for( my $i=$#lines; $i>=0; $i-- ) {
1096 if( $lines[$i] ) {
1097 last;
1098 } else {
1099 $has++;
1100 }
1101 }
1102 for( my $i=0; $i<$endings-$has; $i++ ) {
1103 push @lines, ("");
1104 }
1105 }
1106 $adj += _addChunk( $chunkSign, \$out, \@lines, $start, $adj, $type, $start1, $last, $lengthNew );
1107 print "]\n" if( $DIFF_DEBUG );
1108 }
1109 # Make sure we have the correct number of carriage returns at the end
1110
1111 print "pre end: \"$out\"\n" if( $DIFFEND_DEBUG );
1112 return $out; # . $theEnd;
1113 }
1114 rizwank 1.1
1115
1116 # ======================
1117 =pod
1118
1119 ---++ sub _range ( $start, $end )
1120
1121 Not yet documented.
1122
1123 =cut to implementation
1124
1125 sub _range
1126 {
1127 my( $start, $end ) = @_;
1128 if( $start == $end ) {
1129 return "$start";
1130 } else {
1131 return "$start,$end";
1132 }
1133 }
1134
1135 rizwank 1.1 # ======================
1136 =pod
1137
1138 ---++ sub _addChunk ( $chunkSign, $out, $lines, $start, $adj, $type, $start1, $last, $newLines )
1139
1140 Not yet documented.
1141
1142 =cut to implementation
1143
1144 sub _addChunk
1145 {
1146 my( $chunkSign, $out, $lines, $start, $adj, $type, $start1, $last, $newLines ) = @_;
1147 my $nLines = @$lines;
1148 if( $lines->[$#$lines] =~ /(\n+)$/o ) {
1149 $nLines += ( ( length( $1 ) == 0 ) ? 0 : length( $1 ) -1 );
1150 }
1151 if( $nLines > 0 ) {
1152 print "addChunk chunkSign=$chunkSign start=$start adj=$adj type=$type start1=$start1 " .
1153 "last=$last newLines=$newLines nLines=$nLines\n" if( $DIFF_DEBUG );
1154 $$out .= "\n" if( $$out && $$out !~ /\n$/o );
1155 if( $chunkSign eq "c" ) {
1156 rizwank 1.1 $$out .= _range( $start+1, $start+$nLines/2 );
1157 $$out .= "c";
1158 $$out .= _range( $start1+1, $start1+$nLines/2 );
1159 $$out .= "\n";
1160 $$out .= "< " . join( "< ", @$lines[0..$nLines/2-1] );
1161 $$out .= "\n" if( $lines->[$nLines/2-1] !~ /\n$/o );
1162 $$out .= "---\n";
1163 $$out .= "> " . join( "> ", @$lines[$nLines/2..$nLines-1] );
1164 $nLines = 0;
1165 } elsif( $chunkSign eq "+" ) {
1166 if( $type eq "diff" ) {
1167 $$out .= $start-$adj . "a";
1168 $$out .= _range( $start+1, $start+$nLines ) . "\n";
1169 $$out .= "> " . join( "> ", @$lines );
1170 } else {
1171 $$out .= "a";
1172 $$out .= $start-$adj;
1173 $$out .= " $nLines\n";
1174 $$out .= join( "", @$lines );
1175 }
1176 } else {
1177 rizwank 1.1 print "Start nLines newLines: $start $nLines $newLines\n" if( $DIFF_DEBUG );
1178 if( $type eq "diff" ) {
1179 $$out .= _range( $start+1, $start+$nLines );
1180 $$out .= "d";
1181 $$out .= $start + $adj . "\n";
1182 $$out .= "< " . join( "< ", @$lines );
1183 } else {
1184 $$out .= "d";
1185 $$out .= $start+1;
1186 $$out .= " $nLines";
1187 $$out .= "\n" if( $last );
1188 }
1189 $nLines *= -1;
1190 }
1191 @$lines = ();
1192 }
1193 return $nLines;
1194 }
1195
1196
1197
1198 rizwank 1.1 # ======================
1199 =pod
1200
1201 ---++ sub validTo ( $self )
1202
1203 Not yet documented.
1204
1205 =cut to implementation
1206
1207 sub validTo
1208 {
1209 my( $self ) = @_;
1210 $self->_ensureProcessed();
1211 return $self->{"status"};
1212 }
1213
1214 1;
|
Return to
RcsLite.pm
CVS log
Up to [RizwankCVS] / geekymedia_web / twiki / lib / TWiki / Store