1 rizwank 1.1 # Module of TWiki Collaboration Platform, http://TWiki.org/
  2             #
  3             # Copyright (C) 2001-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             # Jun 2001 - written by John Talintyre, jet@cheerful.com
 26             
 27             =begin twiki
 28             
 29             ---+ TWiki::Meta Module
 30             
 31             This module reads/writes meta data that describes a topic.
 32             Data is held as META:FIELD TWiki variables at the start and end of each topic.
 33             
 34             =cut
 35             
 36             package TWiki::Meta;
 37             
 38             use strict;
 39             
 40             =pod
 41             
 42             ---++ sub new ()
 43 rizwank 1.1 
 44             Not yet documented.
 45             
 46             =cut
 47             
 48             sub new
 49             {
 50                my $self = {};
 51                bless $self;   
 52                return $self;
 53             }
 54             
 55             # ===========================
 56             # Replace data for this type.  If type is keyed then only the entry where
 57             # key matches relavent field is replaced
 58             # Order that args sets are put in is maintained
 59             =pod
 60             
 61             ---++ sub put (  $self, $type, %args  )
 62             
 63             Not yet documented.
 64 rizwank 1.1 
 65             =cut
 66             
 67             sub put
 68             {
 69                my( $self, $type, %args ) = @_;
 70                
 71                my $data = $self->{$type};
 72                my $key = _key( $type );
 73                
 74                if( $data ) {
 75                    if( $key ) {
 76                        my $found = "";
 77                        my $keyName = $args{$key};
 78                        my @data = @$data;
 79                        unless( $keyName ) {
 80                            TWiki::writeWarning( "Meta: Required $key parameter is missing for META:$type" );
 81                            return;
 82                        }
 83                        for( my $i=0; $i<scalar @$data; $i++ ) {
 84                            if( $data[$i]->{$key} eq $keyName ) {
 85 rizwank 1.1                    $data->[$i] = \%args;
 86                                $found = 1;
 87                                last;
 88                            }
 89                        }
 90                        unless( $found ) {
 91                            push @$data, \%args;
 92                        }
 93                    } else {
 94                        $data->[0] = \%args; 
 95                    }
 96             
 97                } else {
 98                    my @data = ( \%args );
 99                    $self->{$type} = \@data;
100                }
101             }
102             
103             # ===========================
104             # Give the key field for a type, "" if no key
105             =pod
106 rizwank 1.1 
107             ---++ sub _key (  $type  )
108             
109             Not yet documented.
110             
111             =cut
112             
113             sub _key
114             {
115                my( $type ) = @_;
116                
117                my $key = "";
118                
119                if( $type eq "FIELD" || $type eq "FILEATTACHMENT" ) {
120                    $key = "name";
121                }
122             }
123             
124             # ===========================
125             # Find one meta data item
126             # Key needed for some types (see _key)
127 rizwank 1.1 =pod
128             
129             ---++ sub findOne (  $self, $type, $keyValue  )
130             
131             Not yet documented.
132             
133             =cut
134             
135             sub findOne
136             {
137                my( $self, $type, $keyValue ) = @_;
138                
139                my %args = ();
140             
141                my $data = $self->{$type};
142                my $key = _key( $type );
143             
144                if( $data ) {
145                    if( $key ) {
146                        foreach my $item ( @$data ) {
147                            if( $item->{$key} eq $keyValue ) {
148 rizwank 1.1                    %args = %$item;
149                                last;
150                            }
151                        }
152                    } else {
153                        my $item = $data->[0];
154                        %args = %$item;
155                    }
156                }
157                
158                return %args;
159             }
160             
161             # ===========================
162             # Get all meta data for a specific type
163             # Returns array, zero length if no items
164             =pod
165             
166             ---++ sub find (  $self, $type  )
167             
168             Not yet documented.
169 rizwank 1.1 
170             =cut
171             
172             sub find
173             {
174                 my( $self, $type ) = @_;
175                 
176                 my $itemsr = $self->{$type};
177                 my @items = ();
178                 
179                 if( $itemsr ) {
180                     @items = @$itemsr;
181                 }
182                 
183                 return @items;
184             }
185             
186             # ===========================
187             # If no keyValue, remove all types, otherwise for types
188             # with key, just remove specified item. Remove all types
189             # if $type is empty.
190 rizwank 1.1 =pod
191             
192             ---++ sub remove (  $self, $type, $keyValue  )
193             
194             Not yet documented.
195             
196             =cut
197             
198             sub remove
199             {
200                 my( $self, $type, $keyValue ) = @_;
201                 
202                 my %args = ();
203                 my $key = "";
204                 $key = _key( $type ) if( $type );
205                 
206                 if( $keyValue && $key ) {
207                    my $data = $self->{$type};
208                    my @newData = ();
209                    foreach my $item ( @$data ) {
210                        if( $item->{$key} ne $keyValue ) {
211 rizwank 1.1                push @newData, $item;
212                        }
213                    }
214                    $self->{$type} = \@newData;
215                 } elsif( $type ) {
216                    delete $self->{$type};
217                 } else {
218                    $self = {};
219                    bless $self;   
220                 }
221             }
222             
223             # ===========================
224             # Copy all entries of a type from another meta data set to self,
225             # overwriting the own set
226             =pod
227             
228             ---++ sub copyFrom (  $self, $otherMeta, $type  )
229             
230             Not yet documented.
231             
232 rizwank 1.1 =cut
233             
234             sub copyFrom
235             {
236                 my( $self, $otherMeta, $type ) = @_;
237             
238                 my $data = $otherMeta->{$type};
239                 $self->{$type} = $data if( $data );
240             }
241             
242             # ===========================
243             # Number of entries of a given type
244             =pod
245             
246             ---++ sub count (  $self, $type  )
247             
248             Not yet documented.
249             
250             =cut
251             
252             sub count
253 rizwank 1.1 {
254                 my( $self, $type ) = @_;
255                 
256                 my $count = 0;
257                 
258                 my $data = $self->{$type};
259                 if( $data ) {
260                    $count = scalar @$data;
261                 }
262                 
263                 return $count;
264             }
265             
266             =pod
267             
268             ---++ sub _writeKeyValue (  $key, $value  )
269             
270             Not yet documented.
271             
272             =cut
273             
274 rizwank 1.1 sub _writeKeyValue
275             {
276                 my( $key, $value ) = @_;
277                 
278                 $value = cleanValue( $value );
279                 
280                 my $text = "$key=\"$value\"";
281                 
282                 return $text;
283             }
284             
285             =pod
286             
287             ---++ sub _writeTypes (  $self, @types  )
288             
289             Not yet documented.
290             
291             =cut
292             
293             sub _writeTypes
294             {
295 rizwank 1.1     my( $self, @types ) = @_;
296                 
297                 my $text = "";
298             
299                 if( $types[0] eq "not" ) {
300                     # write all types that are not in the list
301                     my %seen;
302                     @seen{ @types } = ();
303                     @types = ();  # empty "not in list"
304                     foreach my $key ( keys %$self ) {
305                         push( @types, $key ) unless exists $seen{ $key };
306                     }
307                 }
308                 
309                 foreach my $type ( @types ) {
310                     my $data = $self->{$type};
311                     foreach my $item ( @$data ) {
312                         my $sep = "";
313                         $text .= "%META:$type\{";
314                         my $name = $item->{"name"};
315                         if( $name ) {
316 rizwank 1.1                 # If there's a name field, put first to make regexp based searching easier
317                             $text .= _writeKeyValue( "name", $item->{"name"} );
318                             $sep = " ";
319                         }
320                         foreach my $key ( sort keys %$item ) {
321                             if( $key ne "name" ) {
322                                 $text .= $sep;
323                                 $text .= _writeKeyValue( $key, $item->{$key} );
324                                 $sep = " ";
325                             }
326                         }
327                         $text .= "\}%\n";
328                      }
329                 }
330             
331                 return $text;
332             }
333             
334             =pod
335             
336             ---++ sub cleanValue (  $value  )
337 rizwank 1.1 
338             Not yet documented.
339             
340             =cut
341             
342             sub cleanValue
343             {
344                 my( $value ) = @_;
345             
346                 $value =~ s/\r\r\n/%_N_%/go;
347                 $value =~ s/\r\n/%_N_%/go;
348                 $value =~ s/\n\r/%_N_%/go;
349                 $value =~ s/\r\n/%_N_%/go; # Deal with doubles or \n\r
350                 $value =~ s/\r/\n/go;
351                 $value =~ s/\n/%_N_%/go;
352                 $value =~ s/"/%_Q_%/go;
353             
354                 return $value;
355             }
356             
357             =pod
358 rizwank 1.1 
359             ---++ sub restoreValue (  $value  )
360             
361             Not yet documented.
362             
363             =cut
364             
365             sub restoreValue
366             {
367                 my( $value ) = @_;
368             
369                 $value =~ s/%_N_%/\n/go;
370                 $value =~ s/%_Q_%/"/go;
371             
372                 return $value;
373             }
374             
375             
376             
377             # ======================
378             =pod
379 rizwank 1.1 
380             ---++ sub _keyValue2Hash (  $args  )
381             
382             Not yet documented.
383             
384             =cut
385             
386             sub _keyValue2Hash
387             {
388                 my( $args ) = @_;
389                 
390                 my %res = ();
391                 
392                 # Format of data is name="value" name1="value1" [...]
393                 while( $args =~ s/\s*([^=]+)=\"([^"]*)\"//o ) {
394                     my $key = $1;
395                     my $value = $2;
396                     $value = restoreValue( $value );
397                     $res{$key} = $value;
398                 }
399                 
400 rizwank 1.1     return %res;
401             }
402             
403             # ===========================
404             # Returns text with meta stripped out
405             =pod
406             
407             ---++ sub read (  $self, $text  )
408             
409             Not yet documented.
410             
411             =cut
412             
413             sub read
414             {
415                 my( $self, $text ) = @_;
416                 
417                 my $newText = "";
418             
419                 foreach ( split( /\r?\n/, $text ) ) {
420                     if( /^%META:([^{]+){(.*)}%$/ ) {   # greedy match for ending "}%"
421 rizwank 1.1             my $type = $1;
422                         my $args = $2;
423                         my %list = _keyValue2Hash( $args );
424                         $self->put( $type, %list );
425                     } else {
426                         $newText .= "$_\n";
427                     }
428                 }
429                 
430                 return $newText;
431             }
432             
433             # ===========================
434             # Meta data for start of topic
435             =pod
436             
437             ---++ sub writeStart (  $self  )
438             
439             Not yet documented.
440             
441             =cut
442 rizwank 1.1 
443             sub writeStart
444             {
445                 my( $self ) = @_;
446                 
447                 return $self->_writeTypes( qw/TOPICINFO TOPICPARENT/ );
448             }
449             
450             # ===========================
451             # Meta data for end of topic
452             =pod
453             
454             ---++ sub writeEnd (  $self  )
455             
456             Not yet documented.
457             
458             =cut
459             
460             sub writeEnd
461             {
462                 my( $self ) = @_;
463 rizwank 1.1     
464                 my $text = $self->_writeTypes( qw/FORM FIELD FILEATTACHMENT TOPICMOVED/ );
465                 # append remaining meta data
466                 $text .= $self->_writeTypes( qw/not TOPICINFO TOPICPARENT FORM FIELD FILEATTACHMENT TOPICMOVED/ );
467                 return $text;
468             }
469             
470             # ===========================
471             # Prepend/append meta data to topic
472             =pod
473             
474             ---++ sub write (  $self, $text  )
475             
476             Not yet documented.
477             
478             =cut
479             
480             sub write
481             {
482                 my( $self, $text ) = @_;
483                 
484 rizwank 1.1     my $start = $self->writeStart();
485                 my $end = $self->writeEnd();
486                 $text = $start . "$text";
487                 $text =~ s/([^\n\r])$/$1\n/;     # new line is required at end
488                 $text .= $end;
489                 
490                 return $text;
491             }
492             
493             
494             
495             1;