lib/TWiki/Meta.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
permissions -rw-r--r--
RELEASE 4.2.0 freetown
colas@0
     1
# See bottom of file for license and copyright information
colas@0
     2
colas@0
     3
=pod
colas@0
     4
colas@0
     5
---+ package TWiki::Meta
colas@0
     6
colas@0
     7
All TWiki topics have *data* (text) and *meta-data* (information about the
colas@0
     8
topic). Meta-data includes information such as file attachments, form fields,
colas@0
     9
topic parentage etc. When TWiki loads a topic from the store, it represents
colas@0
    10
the meta-data in the topic using an object of this class.
colas@0
    11
colas@0
    12
A meta-data object is a hash of different types of meta-data (keyed on
colas@0
    13
the type, such as 'FIELD' and 'TOPICINFO').
colas@0
    14
colas@0
    15
Each entry in the hash is an array, where each entry in the array
colas@0
    16
contains another hash of the key=value pairs, corresponding to a
colas@0
    17
single meta-datum.
colas@0
    18
colas@0
    19
If there may be multiple entries of the same top-level type (i.e. for FIELD
colas@0
    20
and FILEATTACHMENT) then the array has multiple entries. These types
colas@0
    21
are referred to as "keyed" types. The array entries are keyed with the
colas@0
    22
attribute 'name' which must be in each entry in the array.
colas@0
    23
colas@0
    24
For unkeyed types, the array has only one entry.
colas@0
    25
colas@0
    26
Pictorially,
colas@0
    27
   * TOPICINFO
colas@0
    28
      * author => '...'
colas@0
    29
      * date => '...'
colas@0
    30
      * ...
colas@0
    31
   * FILEATTACHMENT
colas@0
    32
      * [0] -> { name => '...' ... }
colas@0
    33
      * [1] -> { name => '...' ... }
colas@0
    34
   * FIELD
colas@0
    35
      * [0] -> { name => '...' ... }
colas@0
    36
      * [1] -> { name => '...' ... }
colas@0
    37
colas@0
    38
As well as the meta-data, the object also stores the web name, topic
colas@0
    39
name and remaining text after meta-data extraction.
colas@0
    40
colas@0
    41
=cut
colas@0
    42
colas@0
    43
package TWiki::Meta;
colas@0
    44
colas@0
    45
use strict;
colas@0
    46
use Error qw(:try);
colas@0
    47
use Assert;
colas@0
    48
colas@0
    49
=pod
colas@0
    50
colas@0
    51
---++ ClassMethod new($session, $web, $topic, $text)
colas@0
    52
   * =$session= - a TWiki object (e.g. =$TWiki::Plugins::SESSION)
colas@0
    53
   * =$web=, =$topic= - the topic that the metadata relates to
colas@0
    54
Construct a new, empty object to contain meta-data for the given topic.
colas@0
    55
   * $text - optional raw text to convert to meta-data form
colas@0
    56
=cut
colas@0
    57
colas@0
    58
sub new {
colas@0
    59
    my ( $class, $session, $web, $topic, $text ) = @_;
colas@0
    60
    my $this = bless( { _session => $session }, $class );
colas@0
    61
colas@0
    62
    # Note: internal fields are prepended with _. All uppercase
colas@0
    63
    # fields will be assumed to be meta-data.
colas@0
    64
colas@0
    65
    ASSERT($web) if DEBUG;
colas@0
    66
    ASSERT($topic) if DEBUG;
colas@0
    67
colas@0
    68
    $this->{_web} = $web;
colas@0
    69
    $this->{_topic} = $topic;
colas@0
    70
    $this->{_text} = '';
colas@0
    71
colas@0
    72
    $this->{FILEATTACHMENT} = [];
colas@0
    73
colas@0
    74
    if (defined $text) {
colas@0
    75
        $session->{store}->extractMetaData($this, $text);
colas@0
    76
    }
colas@0
    77
colas@0
    78
    return $this;
colas@0
    79
}
colas@0
    80
colas@0
    81
=begin twiki
colas@0
    82
colas@0
    83
---++ ObjectMethod finish()
colas@0
    84
Break circular references.
colas@0
    85
colas@0
    86
=cut
colas@0
    87
colas@0
    88
# Note to developers; please undef *all* fields in the object explicitly,
colas@0
    89
# whether they are references or not. That way this method is "golden
colas@0
    90
# documentation" of the live fields in the object.
colas@0
    91
sub finish {
colas@0
    92
    my $this = shift;
colas@0
    93
    undef $this->{_web};
colas@0
    94
    undef $this->{_topic};
colas@0
    95
    undef $this->{_text};
colas@0
    96
    undef $this->{_session};
colas@0
    97
}
colas@0
    98
colas@0
    99
=pod
colas@0
   100
colas@0
   101
---++ ObjectMethod session()
colas@0
   102
colas@0
   103
Get the session
colas@0
   104
colas@0
   105
=cut
colas@0
   106
colas@0
   107
sub session {
colas@0
   108
    return $_[0]->{_session};
colas@0
   109
}
colas@0
   110
colas@0
   111
=pod
colas@0
   112
colas@0
   113
---++ ObjectMethod web()
colas@0
   114
colas@0
   115
Get the web name
colas@0
   116
colas@0
   117
=cut
colas@0
   118
colas@0
   119
sub web {
colas@0
   120
    return $_[0]->{_web};
colas@0
   121
}
colas@0
   122
colas@0
   123
=pod
colas@0
   124
colas@0
   125
---++ ObjectMethod topic()
colas@0
   126
colas@0
   127
Get the topic name
colas@0
   128
colas@0
   129
=cut
colas@0
   130
colas@0
   131
sub topic {
colas@0
   132
    return $_[0]->{_topic};
colas@0
   133
}
colas@0
   134
colas@0
   135
=pod
colas@0
   136
colas@0
   137
---++ ObjectMethod text([$text]) -> $text
colas@0
   138
colas@0
   139
Get/set the topic body text. If $text is undef, gets the value, if it is
colas@0
   140
defined, sets the value to that and returns the new text.
colas@0
   141
colas@0
   142
=cut
colas@0
   143
colas@0
   144
sub text {
colas@0
   145
    my ($this, $val) = @_;
colas@0
   146
    if (defined($val)) {
colas@0
   147
        $this->{_text} = $val;
colas@0
   148
    }
colas@0
   149
    return $this->{_text};
colas@0
   150
}
colas@0
   151
colas@0
   152
=pod
colas@0
   153
colas@0
   154
---++ ObjectMethod put($type, \%args)
colas@0
   155
colas@0
   156
Put a hash of key=value pairs into the given type set in this meta. This
colas@0
   157
will *not* replace another value with the same name (for that see =putKeyed=)
colas@0
   158
colas@0
   159
For example, 
colas@0
   160
<verbatim>
colas@0
   161
$meta->put( 'FIELD', { name => 'MaxAge', title => 'Max Age', value =>'103' } );
colas@0
   162
</verbatim>
colas@0
   163
colas@0
   164
=cut
colas@0
   165
colas@0
   166
sub put {
colas@0
   167
    my( $this, $type, $args ) = @_;
colas@0
   168
colas@0
   169
    my $data = $this->{$type};
colas@0
   170
    if( $data ) {
colas@0
   171
        # overwrite old single value
colas@0
   172
        $data->[0] = $args;
colas@0
   173
    } else {
colas@0
   174
        push( @{$this->{$type}}, $args );
colas@0
   175
    }
colas@0
   176
}
colas@0
   177
colas@0
   178
=pod
colas@0
   179
colas@0
   180
---++ ObjectMethod putKeyed($type, \%args)
colas@0
   181
colas@0
   182
Put a hash of key=value pairs into the given type set in this meta, replacing
colas@0
   183
any existing value with the same key.
colas@0
   184
colas@0
   185
For example,
colas@0
   186
<verbatim>
colas@0
   187
$meta->putKeyed( 'FIELD', { name => 'MaxAge', title => 'Max Age', value =>'103' } );
colas@0
   188
</verbatim>
colas@0
   189
colas@0
   190
=cut
colas@0
   191
colas@0
   192
# Note: Array is used instead of a hash to preserve sequence
colas@0
   193
colas@0
   194
sub putKeyed {
colas@0
   195
    my( $this, $type, $args ) = @_;
colas@0
   196
colas@0
   197
    my $data = $this->{$type};
colas@0
   198
    if( $data ) {
colas@0
   199
        my $keyName = $args->{name};
colas@0
   200
        ASSERT( $keyName ) if DEBUG;
colas@0
   201
        my $i = scalar( @$data );
colas@0
   202
        while( $keyName && $i-- ) {
colas@0
   203
            if( $data->[$i]->{name} eq $keyName ) {
colas@0
   204
                $data->[$i] = $args;
colas@0
   205
                return;
colas@0
   206
            }
colas@0
   207
        }
colas@0
   208
        push @$data, $args;
colas@0
   209
    } else {
colas@0
   210
      push( @{$this->{$type}}, $args );
colas@0
   211
    }
colas@0
   212
}
colas@0
   213
colas@0
   214
=pod
colas@0
   215
colas@0
   216
---++ ObjectMethod putAll
colas@0
   217
colas@0
   218
Replaces all the items of a given key with a new array.
colas@0
   219
colas@0
   220
For example,
colas@0
   221
<verbatim>
colas@0
   222
$meta->putAll( 'FIELD',
colas@0
   223
     { name => 'MinAge', title => 'Min Age', value =>'50' },
colas@0
   224
     { name => 'MaxAge', title => 'Max Age', value =>'103' },
colas@0
   225
     { name => 'HairColour', title => 'Hair Colour', value =>'white' }
colas@0
   226
 );
colas@0
   227
</verbatim>
colas@0
   228
colas@0
   229
=cut
colas@0
   230
colas@0
   231
sub putAll {
colas@0
   232
    my( $this, $type, @array ) = @_;
colas@0
   233
colas@0
   234
    $this->{$type} = \@array;
colas@0
   235
}
colas@0
   236
colas@0
   237
=pod
colas@0
   238
colas@0
   239
---++ ObjectMethod get( $type, $key ) -> \%hash
colas@0
   240
colas@0
   241
Find the value of a meta-datum in the map. If the type is
colas@0
   242
keyed (idenitifed by a =name=), the =$key= parameter is required
colas@0
   243
to say _which_ entry you want. Otherwise you will just get the first value.
colas@0
   244
colas@0
   245
If you want all the keys of a given type use the 'find' method.
colas@0
   246
colas@0
   247
The result is a reference to the hash for the item.
colas@0
   248
colas@0
   249
For example,
colas@0
   250
<verbatim>
colas@0
   251
my $ma = $meta->get( 'FIELD', 'MinAge' );
colas@0
   252
my $topicinfo = $meta->get( 'TOPICINFO' ); # get the TOPICINFO hash
colas@0
   253
</verbatim>
colas@0
   254
colas@0
   255
=cut
colas@0
   256
colas@0
   257
sub get {
colas@0
   258
    my( $this, $type, $keyValue ) = @_;
colas@0
   259
colas@0
   260
    my $data = $this->{$type};
colas@0
   261
    if( $data ) {
colas@0
   262
        if( defined $keyValue ) {
colas@0
   263
            foreach my $item ( @$data ) {
colas@0
   264
                return $item if( $item->{name} eq $keyValue );
colas@0
   265
            }
colas@0
   266
        } else {
colas@0
   267
            return $data->[0];
colas@0
   268
        }
colas@0
   269
    }
colas@0
   270
colas@0
   271
    return undef;
colas@0
   272
}
colas@0
   273
colas@0
   274
=pod
colas@0
   275
colas@0
   276
---++ ObjectMethod find (  $type  ) -> @values
colas@0
   277
colas@0
   278
Get all meta data for a specific type.
colas@0
   279
Returns the array stored for the type. This will be zero length
colas@0
   280
if there are no entries.
colas@0
   281
colas@0
   282
For example,
colas@0
   283
<verbatim>
colas@0
   284
my $attachments = $meta->find( 'FILEATTACHMENT' );
colas@0
   285
</verbatim>
colas@0
   286
colas@0
   287
=cut
colas@0
   288
colas@0
   289
sub find {
colas@0
   290
    my( $this, $type ) = @_;
colas@0
   291
colas@0
   292
    my $itemsr = $this->{$type};
colas@0
   293
    my @items = ();
colas@0
   294
colas@0
   295
    if( $itemsr ) {
colas@0
   296
        @items = @$itemsr;
colas@0
   297
    }
colas@0
   298
colas@0
   299
    return @items;
colas@0
   300
}
colas@0
   301
colas@0
   302
=pod
colas@0
   303
colas@0
   304
---++ ObjectMethod remove($type, $key)
colas@0
   305
colas@0
   306
With no type, will remove all the contents of the object.
colas@0
   307
colas@0
   308
With a $type but no $key, will remove _all_ items of that type (so for example if $type were FILEATTACHMENT it would remove all of them)
colas@0
   309
colas@0
   310
With a $type and a $key it will remove only the specific item.
colas@0
   311
colas@0
   312
=cut
colas@0
   313
colas@0
   314
sub remove {
colas@0
   315
    my( $this, $type, $keyValue ) = @_;
colas@0
   316
colas@0
   317
    if( $keyValue ) {
colas@0
   318
       my $data = $this->{$type};
colas@0
   319
       my @newData = ();
colas@0
   320
       foreach my $item ( @$data ) {
colas@0
   321
           if( $item->{name} ne $keyValue ) {
colas@0
   322
               push @newData, $item;
colas@0
   323
           }
colas@0
   324
       }
colas@0
   325
       $this->{$type} = \@newData;
colas@0
   326
    } elsif( $type ) {
colas@0
   327
       delete $this->{$type};
colas@0
   328
    } else {
colas@0
   329
        foreach my $entry ( keys %$this ) {
colas@0
   330
            unless( $entry =~ /^_/ ) {
colas@0
   331
                $this->remove( $entry );
colas@0
   332
            }
colas@0
   333
        }
colas@0
   334
    }
colas@0
   335
}
colas@0
   336
colas@0
   337
=pod
colas@0
   338
colas@0
   339
---++ ObjectMethod copyFrom( $otherMeta, $type, $nameFilter )
colas@0
   340
colas@0
   341
Copy all entries of a type from another meta data set. This
colas@0
   342
will destroy the old values for that type, unless the
colas@0
   343
copied object doesn't contain entries for that type, in which
colas@0
   344
case it will retain the old values.
colas@0
   345
colas@0
   346
If $type is undef, will copy ALL TYPES.
colas@0
   347
colas@0
   348
If $nameFilter is defined (a perl refular expression), it will copy
colas@0
   349
only data where ={name}= matches $nameFilter.
colas@0
   350
colas@0
   351
Does *not* copy web, topic or text.
colas@0
   352
colas@0
   353
=cut
colas@0
   354
colas@0
   355
sub copyFrom {
colas@0
   356
    my( $this, $otherMeta, $type, $filter ) = @_;
colas@0
   357
    ASSERT($otherMeta->isa( 'TWiki::Meta')) if DEBUG;
colas@0
   358
colas@0
   359
    if( $type ) {
colas@0
   360
        foreach my $item ( @{$otherMeta->{$type}} ) {
colas@0
   361
            if( !$filter || ( $item->{name} && $item->{name} =~ /$filter/ )) {
colas@0
   362
                my %data = map { $_ => $item->{$_} } keys %$item;
colas@0
   363
                push( @{$this->{$type}}, \%data );
colas@0
   364
            }
colas@0
   365
        }
colas@0
   366
    } else {
colas@0
   367
        foreach my $k ( keys %$otherMeta ) {
colas@0
   368
            # Don't copy the web and topic fields, this may be a new topic
colas@0
   369
            unless( $k =~ /^_/ ) {
colas@0
   370
                $this->copyFrom( $otherMeta, $k );
colas@0
   371
            }
colas@0
   372
        }
colas@0
   373
    }
colas@0
   374
}
colas@0
   375
colas@0
   376
=pod
colas@0
   377
colas@0
   378
---++ ObjectMethod count($type) -> $integer
colas@0
   379
colas@0
   380
Return the number of entries of the given type
colas@0
   381
colas@0
   382
=cut
colas@0
   383
colas@0
   384
sub count {
colas@0
   385
    my( $this, $type ) = @_;
colas@0
   386
    my $data = $this->{$type};
colas@0
   387
colas@0
   388
    return scalar @$data if( defined( $data ));
colas@0
   389
colas@0
   390
    return 0;
colas@0
   391
}
colas@0
   392
colas@0
   393
=pod
colas@0
   394
colas@0
   395
---++ ObjectMethod getRevisionInfo($fromrev) -> ( $date, $author, $rev, $comment )
colas@0
   396
colas@0
   397
Try and get revision info from the meta information, or, if it is not
colas@0
   398
present, kick down to the Store module for the same information.
colas@0
   399
colas@0
   400
Returns ( $revDate, $author, $rev, $comment )
colas@0
   401
colas@0
   402
$rev is an integer revision number.
colas@0
   403
colas@0
   404
=cut
colas@0
   405
colas@0
   406
sub getRevisionInfo {
colas@0
   407
    my( $this, $fromrev ) = @_;
colas@0
   408
    my $store = $this->{_session}->{store};
colas@0
   409
colas@0
   410
    my $topicinfo = $this->get( 'TOPICINFO' );
colas@0
   411
colas@0
   412
    my( $date, $author, $rev, $comment );
colas@0
   413
    if( $topicinfo ) {
colas@0
   414
        $date = $topicinfo->{date} ;
colas@0
   415
        $author = $topicinfo->{author};
colas@0
   416
        $rev = $topicinfo->{version};
colas@0
   417
        $rev =~ s/^\$Rev(:\s*\d+)?\s*\$$/0/; # parse out SVN keywords in doc
colas@0
   418
        $rev =~ s/^\d+\.//;
colas@0
   419
        $comment = '';
colas@0
   420
        if ( !$fromrev || $rev eq $fromrev ) {
colas@0
   421
            return( $date, $author, $rev, $comment );
colas@0
   422
        }
colas@0
   423
    }
colas@0
   424
    # Different rev, or no topic info, delegate to Store
colas@0
   425
    ( $date, $author, $rev, $comment ) =
colas@0
   426
      $store->getRevisionInfo( $this->{_web}, $this->{_topic}, $fromrev );
colas@0
   427
    return( $date, $author, $rev, $comment );
colas@0
   428
}
colas@0
   429
colas@0
   430
=pod
colas@0
   431
colas@0
   432
---++ ObjectMethod merge( $otherMeta, $formDef )
colas@0
   433
colas@0
   434
   * =$otherMeta= - a block of meta-data to merge with $this
colas@0
   435
   * =$formDef= reference to a TWiki::Form that gives the types of the fields in $this
colas@0
   436
colas@0
   437
Merge the data in the other meta block.
colas@0
   438
   * File attachments that only appear in one set are preserved.
colas@0
   439
   * Form fields that only appear in one set are preserved.
colas@0
   440
   * Form field values that are different in each set are text-merged
colas@0
   441
   * We don't merge for field attributes or title
colas@0
   442
   * Topic info is not touched
colas@0
   443
   * The =mergeable= method on the form def is used to determine if that fields is mergeable. if it isn't, the value currently in meta will _not_ be changed.
colas@0
   444
colas@0
   445
=cut
colas@0
   446
colas@0
   447
sub merge {
colas@0
   448
    my ( $this, $other, $formDef ) = @_;
colas@0
   449
colas@0
   450
    my $data = $other->{FIELD};
colas@0
   451
    if( $data ) {
colas@0
   452
        foreach my $otherD ( @$data ) {
colas@0
   453
            my $thisD = $this->get( 'FIELD', $otherD->{name} );
colas@0
   454
            if ( $thisD && $thisD->{value} ne $otherD->{value} ) {
colas@0
   455
                if( $formDef->isTextMergeable( $thisD->{name} )) {
colas@0
   456
                    require TWiki::Merge;
colas@0
   457
                    my $merged = TWiki::Merge::merge2(
colas@0
   458
                        'A', $otherD->{value}, 'B', $thisD->{value},
colas@0
   459
                        '.*?\s+',
colas@0
   460
                        $this->{_session},
colas@0
   461
                        $formDef->getField( $thisD->{name} ) );
colas@0
   462
                    # SMELL: we don't merge attributes or title
colas@0
   463
                    $thisD->{value} = $merged;
colas@0
   464
                }
colas@0
   465
            } elsif ( !$thisD ) {
colas@0
   466
                $this->putKeyed('FIELD', $otherD );
colas@0
   467
            }
colas@0
   468
        }
colas@0
   469
    }
colas@0
   470
colas@0
   471
    $data = $other->{FILEATTACHMENT};
colas@0
   472
    if( $data ) {
colas@0
   473
        foreach my $otherD ( @$data ) {
colas@0
   474
            my $thisD = $this->get( 'FILEATTACHMENT', $otherD->{name} );
colas@0
   475
            if ( !$thisD ) {
colas@0
   476
                $this->putKeyed('FILEATTACHMENT', $otherD );
colas@0
   477
            }
colas@0
   478
        }
colas@0
   479
    }
colas@0
   480
}
colas@0
   481
colas@0
   482
=pod
colas@0
   483
colas@0
   484
---++ ObjectMethod stringify( $types ) -> $string
colas@0
   485
colas@0
   486
Return a string version of the meta object. Uses \n to separate lines.
colas@0
   487
If =$types= is specified, return only types
colas@0
   488
that match it. Types should be a perl regular expression.
colas@0
   489
colas@0
   490
=cut
colas@0
   491
colas@0
   492
sub stringify {
colas@0
   493
    my( $this, $types ) = @_;
colas@0
   494
    my $s = '';
colas@0
   495
    $types ||= qr/^[A-Z]+$/;
colas@0
   496
colas@0
   497
    foreach my $type ( grep { /$types/ } keys %$this ) {
colas@0
   498
        foreach my $item ( @{$this->{$type}} ) {
colas@0
   499
            $s .= "$type: " .
colas@0
   500
              join(' ', map{ "$_='".($item->{$_}||'')."'" }
colas@0
   501
                     sort keys %$item ) .
colas@0
   502
                       "\n";
colas@0
   503
        }
colas@0
   504
    }
colas@0
   505
    return $s;
colas@0
   506
}
colas@0
   507
colas@0
   508
=pod
colas@0
   509
colas@0
   510
---++ ObjectMethod forEachSelectedValue( $types, $keys, \&fn, \%options )
colas@0
   511
colas@0
   512
Iterate over the values selected by the regular expressions in $types and
colas@0
   513
$keys.
colas@0
   514
   * =$types= - regular expression matching the names of fields to be processed. Will default to qr/^[A-Z]+$/ if undef.
colas@0
   515
   * =$keys= - regular expression matching the names of keys to be processed.  Will default to qr/^[a-z]+$/ if undef.
colas@0
   516
colas@0
   517
Iterates over each value, calling =\&fn= on each, and replacing the value
colas@0
   518
with the result of \&fn.
colas@0
   519
colas@0
   520
\%options will be passed on to $fn, with the following additions:
colas@0
   521
   * =_type= => the type name (e.g. "FILEATTACHMENT")
colas@0
   522
   * =_key= => the key name (e.g. "user")
colas@0
   523
colas@0
   524
=cut
colas@0
   525
colas@0
   526
sub forEachSelectedValue {
colas@0
   527
    my( $this, $types, $keys, $fn, $options ) = @_;
colas@0
   528
colas@0
   529
    $types ||= qr/^[A-Z]+$/;
colas@0
   530
    $keys ||= qr/^[a-z]+$/;
colas@0
   531
colas@0
   532
    foreach my $type ( grep { /$types/ } keys %$this ) {
colas@0
   533
        $options->{_type} = $type;
colas@0
   534
        my $data = $this->{$type};
colas@0
   535
        next unless $data;
colas@0
   536
        foreach my $datum ( @$data ) {
colas@0
   537
            foreach my $key ( grep { /$keys/ } keys %$datum ) {
colas@0
   538
                $options->{_key} = $key;
colas@0
   539
                $datum->{$key} = &$fn( $datum->{$key}, $options );
colas@0
   540
            }
colas@0
   541
        }
colas@0
   542
    }
colas@0
   543
}
colas@0
   544
colas@0
   545
=pod
colas@0
   546
colas@0
   547
---++ ObjectMethod getParent() -> $parent
colas@0
   548
colas@0
   549
Gets the TOPICPARENT name.
colas@0
   550
colas@0
   551
=cut
colas@0
   552
colas@0
   553
sub getParent {
colas@0
   554
    my( $this ) = @_;
colas@0
   555
colas@0
   556
    my $value = '';
colas@0
   557
    my $parent = $this->get( 'TOPICPARENT' );
colas@0
   558
    $value = $parent->{name} if( $parent );
colas@0
   559
    # Return empty string (not undef), if TOPICPARENT meta is broken
colas@0
   560
    $value = '' if (!defined $value);
colas@0
   561
    return $value;
colas@0
   562
}
colas@0
   563
colas@0
   564
=pod
colas@0
   565
colas@0
   566
---++ ObjectMethod getFormName() -> $formname
colas@0
   567
colas@0
   568
Returns the name of the FORM, or '' if none.
colas@0
   569
colas@0
   570
=cut
colas@0
   571
colas@0
   572
sub getFormName {
colas@0
   573
    my( $this ) = @_;
colas@0
   574
colas@0
   575
    my $aForm = $this->get( 'FORM' );
colas@0
   576
    if( $aForm ) {
colas@0
   577
        return $aForm->{name};
colas@0
   578
    }
colas@0
   579
    return '';
colas@0
   580
}
colas@0
   581
colas@0
   582
=pod
colas@0
   583
colas@0
   584
---++ ObjectMethod renderFormForDisplay() -> $html
colas@0
   585
colas@0
   586
Render the form contained in the meta for display.
colas@0
   587
colas@0
   588
=cut
colas@0
   589
colas@0
   590
sub renderFormForDisplay {
colas@0
   591
    my $this = shift;
colas@0
   592
colas@0
   593
    my $fname = $this->getFormName();
colas@0
   594
colas@0
   595
    require TWiki::Form;
colas@0
   596
    return '' unless $fname;
colas@0
   597
colas@0
   598
    my $form = new TWiki::Form( $this->{_session}, $this->{_web}, $fname );
colas@0
   599
colas@0
   600
    if( $form ) {
colas@0
   601
        return $form->renderForDisplay( $this );
colas@0
   602
    } else {
colas@0
   603
        return CGI::span({class => 'twikiAlert'},
colas@0
   604
                         "Form definition '$fname' not found");
colas@0
   605
    }
colas@0
   606
}
colas@0
   607
colas@0
   608
=pod
colas@0
   609
colas@0
   610
---++ ObjectMethod renderFormFieldForDisplay($name, $format, $attrs) -> $text
colas@0
   611
colas@0
   612
Render a single formfield, using the $format. See
colas@0
   613
TWiki::Form::FormField::renderForDisplay for a description of how the value
colas@0
   614
is rendered.
colas@0
   615
colas@0
   616
=cut
colas@0
   617
colas@0
   618
sub renderFormFieldForDisplay {
colas@0
   619
    my( $this, $name, $format, $attrs ) = @_;
colas@0
   620
colas@0
   621
    my $value;
colas@0
   622
    my $mf = $this->get( 'FIELD', $name );
colas@0
   623
    unless( $mf ) {
colas@0
   624
        # Not a valid field name, maybe it's a title.
colas@0
   625
        require TWiki::Form;
colas@0
   626
        $name = TWiki::Form::fieldTitle2FieldName( $name );
colas@0
   627
        $mf = $this->get( 'FIELD', $name);
colas@0
   628
    }
colas@0
   629
    return '' unless $mf; # field not found
colas@0
   630
colas@0
   631
    $value = $mf->{value};
colas@0
   632
colas@0
   633
    my $fname = $this->getFormName();
colas@0
   634
    if( $fname ) {
colas@0
   635
        require TWiki::Form;
colas@0
   636
        my $form = new TWiki::Form( $this->{_session}, $this->{_web}, $fname );
colas@0
   637
        if( $form ) {
colas@0
   638
            my $field = $form->getField( $name );
colas@0
   639
            if( $field ) {
colas@0
   640
                return $field->renderForDisplay( $format, $value, $attrs );
colas@0
   641
            }
colas@0
   642
        }
colas@0
   643
    }
colas@0
   644
    # Form or field wasn't found, do your best!
colas@0
   645
    my $f = $this->get( 'FIELD', $name );
colas@0
   646
    if( $f ) {
colas@0
   647
        $format =~ s/\$title/$f->{title}/;
colas@0
   648
        require TWiki::Render;
colas@0
   649
        $value = TWiki::Render::protectFormFieldValue( $value, $attrs );
colas@0
   650
        $format =~ s/\$value/$value/;
colas@0
   651
    }
colas@0
   652
    return $format;
colas@0
   653
}
colas@0
   654
colas@0
   655
=pod
colas@0
   656
colas@0
   657
---++ ObjectMethod getEmbeddedStoreForm() -> $text
colas@0
   658
colas@0
   659
Generate the embedded store form of the topic. The embedded store
colas@0
   660
form has meta-data values embedded using %META: lines. The text
colas@0
   661
stored in the meta is taken as the topic text.
colas@0
   662
colas@0
   663
=cut
colas@0
   664
colas@0
   665
sub getEmbeddedStoreForm {
colas@0
   666
    my $this = shift;
colas@0
   667
    $this->{_text} ||= '';
colas@0
   668
colas@0
   669
    require TWiki::Store;
colas@0
   670
colas@0
   671
    my $start = $this->_writeTypes( qw/TOPICINFO TOPICPARENT/ );
colas@0
   672
    my $end = $this->_writeTypes( qw/FORM FIELD FILEATTACHMENT TOPICMOVED/ );
colas@0
   673
    # append remaining meta data
colas@0
   674
    $end .= $this->_writeTypes( qw/not TOPICINFO TOPICPARENT FORM FIELD FILEATTACHMENT TOPICMOVED/ );
colas@0
   675
    my $text = $start . $this->{_text};
colas@0
   676
    $end = "\n".$end if $end;
colas@0
   677
    $text .= $end;
colas@0
   678
    return $text;
colas@0
   679
}
colas@0
   680
colas@0
   681
# STATIC Write a meta-data key=value pair
colas@0
   682
# The encoding is reversed in _readKeyValues
colas@0
   683
sub _writeKeyValue {
colas@0
   684
    my( $key, $value ) = @_;
colas@0
   685
colas@0
   686
    if( defined( $value )) {
colas@0
   687
        $value = TWiki::Store::dataEncode( $value );
colas@0
   688
    } else {
colas@0
   689
        $value = '';
colas@0
   690
    }
colas@0
   691
colas@0
   692
    return $key.'="'.$value.'"';
colas@0
   693
}
colas@0
   694
colas@0
   695
# STATIC: Write all the key=value pairs for the types listed
colas@0
   696
sub _writeTypes {
colas@0
   697
    my( $this, @types ) = @_;
colas@0
   698
colas@0
   699
    my $text = '';
colas@0
   700
colas@0
   701
    if( $types[0] eq 'not' ) {
colas@0
   702
        # write all types that are not in the list
colas@0
   703
        my %seen;
colas@0
   704
        @seen{ @types } = ();
colas@0
   705
        @types = ();  # empty "not in list"
colas@0
   706
        foreach my $key ( keys %$this ) {
colas@0
   707
            push( @types, $key ) unless
colas@0
   708
              (exists $seen{ $key } || $key =~ /^_/);
colas@0
   709
        }
colas@0
   710
    }
colas@0
   711
colas@0
   712
    foreach my $type ( @types ) {
colas@0
   713
        my $data = $this->{$type};
colas@0
   714
        foreach my $item ( @$data ) {
colas@0
   715
            my $sep = '';
colas@0
   716
            $text .= '%META:'.$type.'{';
colas@0
   717
            my $name = $item->{name};
colas@0
   718
            if( $name ) {
colas@0
   719
                # If there's a name field, put first to make regexp based searching easier
colas@0
   720
                $text .= _writeKeyValue( 'name', $item->{name} );
colas@0
   721
                $sep = ' ';
colas@0
   722
            }
colas@0
   723
            foreach my $key ( sort keys %$item ) {
colas@0
   724
                if( $key ne 'name' ) {
colas@0
   725
                    $text .= $sep;
colas@0
   726
                    $text .= _writeKeyValue( $key, $item->{$key} );
colas@0
   727
                    $sep = ' ';
colas@0
   728
                }
colas@0
   729
            }
colas@0
   730
            $text .= '}%'."\n";
colas@0
   731
        }
colas@0
   732
    }
colas@0
   733
colas@0
   734
    return $text;
colas@0
   735
}
colas@0
   736
colas@0
   737
# Note: not published as part of the interface; private to TWiki
colas@0
   738
# Add TOPICINFO type data to the object, as specified by the parameters.
colas@0
   739
#    * =$rev= - the revision number
colas@0
   740
#    * =$time= - the time stamp
colas@0
   741
#    * =$user= - the user id
colas@0
   742
#    * =$repRev= - is the save in progress a repRev
colas@0
   743
# SMELL: Duplicate rev control info in the topic
colas@0
   744
sub addTOPICINFO {
colas@0
   745
    my( $this, $rev, $time, $user, $repRev, $format ) = @_;
colas@0
   746
    $rev = 1 if $rev < 1;
colas@0
   747
    my $users = $this->{_session}->{users};
colas@0
   748
colas@0
   749
    my %options =
colas@0
   750
      (
colas@0
   751
          # compatibility; older versions of the code use
colas@0
   752
          # RCS rev numbers save with them so old code can
colas@0
   753
          # read these topics
colas@0
   754
          version   => '1.'.$rev,
colas@0
   755
          date      => $time,
colas@0
   756
          author    => $user,
colas@0
   757
          format    => $format,
colas@0
   758
         );
colas@0
   759
    # if this is a reprev, then store the revision that was affected.
colas@0
   760
    # Required so we can tell when a merge is based on something that
colas@0
   761
    # is *not* the original rev where another users' edit started.
colas@0
   762
    # See Bugs:Item1897.
colas@0
   763
    $options{reprev} = '1.'.$rev if $repRev;
colas@0
   764
colas@0
   765
    $this->put( 'TOPICINFO', \%options );
colas@0
   766
}
colas@0
   767
colas@0
   768
=begin twiki
colas@0
   769
colas@0
   770
---++ ObjectMethod getMetaFor() -> $meta
colas@0
   771
colas@0
   772
This method will load (or otherwise fetch) the meta-data for a named web/topic.
colas@0
   773
The request might be satisfied by a read from the store, or it might be
colas@0
   774
satisfied from a cache. The caller doesn't care.
colas@0
   775
colas@0
   776
This is an object method rather than a static method because it depends on
colas@0
   777
the implementation of Meta - it might be this base class, or it might be a
colas@0
   778
caching subclass, for example.
colas@0
   779
colas@0
   780
=cut
colas@0
   781
colas@0
   782
sub getMetaFor {
colas@0
   783
    my ($this, $web, $topic) = @_;
colas@0
   784
colas@0
   785
    my ($m, $t) =  $this->session->{store}->readTopic(undef, $web, $topic);
colas@0
   786
    return $m; # $t is already in $m->text()
colas@0
   787
}
colas@0
   788
colas@0
   789
1;
colas@0
   790
colas@0
   791
__DATA__
colas@0
   792
colas@0
   793
Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
colas@0
   794
colas@0
   795
Copyright (C) 2001-2007 Peter Thoeny, peter@thoeny.org
colas@0
   796
and TWiki Contributors. All Rights Reserved. TWiki Contributors
colas@0
   797
are listed in the AUTHORS file in the root of this distribution.
colas@0
   798
NOTE: Please extend that file, not this notice.
colas@0
   799
colas@0
   800
This program is free software; you can redistribute it and/or
colas@0
   801
modify it under the terms of the GNU General Public License
colas@0
   802
as published by the Free Software Foundation; either version 2
colas@0
   803
of the License, or (at your option) any later version. For
colas@0
   804
more details read LICENSE in the root of this distribution.
colas@0
   805
colas@0
   806
This program is distributed in the hope that it will be useful,
colas@0
   807
but WITHOUT ANY WARRANTY; without even the implied warranty of
colas@0
   808
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
colas@0
   809
colas@0
   810
As per the GPL, removal of this notice is prohibited.