lib/TWiki/Attrs.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
permissions -rw-r--r--
RELEASE 4.2.0 freetown
colas@0
     1
# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
colas@0
     2
#
colas@0
     3
# Copyright (C) 1999-2007 TWiki Contributors. All Rights Reserved.
colas@0
     4
# TWiki Contributors are listed in the AUTHORS file in the root of
colas@0
     5
# this distribution. NOTE: Please extend that file, not this notice.
colas@0
     6
#
colas@0
     7
# Additional copyrights apply to some or all of the code in this
colas@0
     8
# file as follows:
colas@0
     9
# Derived from Contrib::Attrs, which is
colas@0
    10
# Copyright (C) 2001 Motorola - All rights reserved
colas@0
    11
#
colas@0
    12
# This program is free software; you can redistribute it and/or
colas@0
    13
# modify it under the terms of the GNU General Public License
colas@0
    14
# as published by the Free Software Foundation; either version 2
colas@0
    15
# of the License, or (at your option) any later version. For
colas@0
    16
# more details read LICENSE in the root of this distribution.
colas@0
    17
#
colas@0
    18
# This program is distributed in the hope that it will be useful,
colas@0
    19
# but WITHOUT ANY WARRANTY; without even the implied warranty of
colas@0
    20
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
colas@0
    21
#
colas@0
    22
# As per the GPL, removal of this notice is prohibited.
colas@0
    23
colas@0
    24
=pod
colas@0
    25
colas@0
    26
---+ package TWiki::Attrs
colas@0
    27
colas@0
    28
Class of attribute sets, designed for parsing and storing attribute values
colas@0
    29
from a TWiki tag e.g. =%<nop>TAG{"joe" fred="bad" joe="mad"}%=
colas@0
    30
colas@0
    31
An attribute set is a hash containing an entry for each parameter. The
colas@0
    32
default parameter (unnamed quoted string) is named <code>_<nop>DEFAULT</code> in the hash.
colas@0
    33
colas@0
    34
Attributes declared later in the string will override those of the same
colas@0
    35
name defined earlier. The one exception to this is the _DEFAULT key, where
colas@0
    36
the _first_ instance is always taken.
colas@0
    37
colas@0
    38
As well as the default TWiki syntax (parameter values double-quoted)
colas@0
    39
this class also parses single-quoted values, unquoted spaceless
colas@0
    40
values, spaces around the =, and commas as well as spaces separating values.
colas@0
    41
The extended syntax has to be enabled by passing the =$friendly= parameter
colas@0
    42
to =new=.
colas@0
    43
colas@0
    44
=cut
colas@0
    45
colas@0
    46
package TWiki::Attrs;
colas@0
    47
colas@0
    48
use strict;
colas@0
    49
use Assert;
colas@0
    50
colas@0
    51
use vars qw( $ERRORKEY $DEFAULTKEY $RAWKEY );
colas@0
    52
colas@0
    53
$ERRORKEY   = '_ERROR';
colas@0
    54
$DEFAULTKEY = '_DEFAULT';
colas@0
    55
$RAWKEY     = '_RAW';
colas@0
    56
colas@0
    57
=pod
colas@0
    58
colas@0
    59
---++ ClassMethod new ($string, $friendly) => \%attrsObjectRef
colas@0
    60
colas@0
    61
   * =$string= - String containing attribute specification
colas@0
    62
   * =$friendly= - if true, the parse will be according to the extended syntax pioneered by the original Contrib::Attrs. Otherwise it will be strict as per traditional TWiki syntax.
colas@0
    63
colas@0
    64
Parse a standard attribute string containing name=value pairs and create a new
colas@0
    65
attributes object. The value may be a word or a quoted string. If there is an
colas@0
    66
error during parsing, the parse will complete but $attrs->{_ERROR} will be
colas@0
    67
set in the new object. $attrs->{_RAW} will always contain the full unprocessed
colas@0
    68
$string.
colas@0
    69
colas@0
    70
Extended syntax example:
colas@0
    71
<verbatim>
colas@0
    72
my $attrs = new TWiki::Attrs('the="time \\"has come", "the walrus" said to=speak of=\'many \\'things\', 1);
colas@0
    73
</verbatim>
colas@0
    74
In this example:
colas@0
    75
   * =the= will be =time "has come=
colas@0
    76
   * <code>_<nop>_<nop>default__</code> will be =the walrus=
colas@0
    77
   * =said= will be =on=
colas@0
    78
   * =to= will be =speak=
colas@0
    79
   * =of= will be =many 'things=
colas@0
    80
colas@0
    81
Only " and ' are escaped.
colas@0
    82
colas@0
    83
Traditional syntax is as old TWiki, except that the whole string is parsed
colas@0
    84
(the old parser would only recognise default values in position 1, nowhere
colas@0
    85
else)
colas@0
    86
colas@0
    87
=cut
colas@0
    88
colas@0
    89
sub new {
colas@0
    90
    my ( $class, $string, $friendly ) = @_;
colas@0
    91
    my $this = bless( {}, $class );
colas@0
    92
colas@0
    93
    $this->{$RAWKEY} = $string;
colas@0
    94
colas@0
    95
    return $this unless defined( $string );
colas@0
    96
colas@0
    97
    $string =~ s/\\(["'])/$TWiki::TranslationToken.sprintf("%.2u", ord($1))/ge;  # escapes
colas@0
    98
colas@0
    99
    my $sep = ( $friendly ? "[\\s,]" : "\\s" );
colas@0
   100
    my $first = 1;
colas@0
   101
colas@0
   102
    if( !$friendly && $string =~ s/^\s*\"(.*?)\"\s*(\w+\s*=\s*\"|$)/$2/s ) {
colas@0
   103
        $this->{$DEFAULTKEY} = $1;
colas@0
   104
    }
colas@0
   105
    while ( $string =~ m/\S/s ) {
colas@0
   106
        # name="value" pairs
colas@0
   107
        if ( $string =~ s/^$sep*(\w+)\s*=\s*\"(.*?)\"//is ) {
colas@0
   108
            $this->{$1} = $2;
colas@0
   109
            $first = 0;
colas@0
   110
        }
colas@0
   111
        # simple double-quoted value with no name, sets the default
colas@0
   112
        elsif ( $string =~ s/^$sep*\"(.*?)\"//os ) {
colas@0
   113
            $this->{$DEFAULTKEY} = $1
colas@0
   114
              unless defined( $this->{$DEFAULTKEY} );
colas@0
   115
            $first = 0;
colas@0
   116
        }
colas@0
   117
        elsif ( $friendly ) {
colas@0
   118
            # name='value' pairs
colas@0
   119
            if ( $string =~ s/^$sep*(\w+)\s*=\s*'(.*?)'//is ) {
colas@0
   120
                $this->{$1} = $2;
colas@0
   121
            }
colas@0
   122
            # name=value pairs
colas@0
   123
            elsif ( $string =~ s/^$sep*(\w+)\s*=\s*([^\s,\}\'\"]*)//is ) {
colas@0
   124
                $this->{$1} = $2;
colas@0
   125
            }
colas@0
   126
            # simple single-quoted value with no name, sets the default
colas@0
   127
            elsif ( $string =~ s/^$sep*'(.*?)'//os ) {
colas@0
   128
                $this->{$DEFAULTKEY} = $1
colas@0
   129
                  unless defined( $this->{$DEFAULTKEY} );
colas@0
   130
            }
colas@0
   131
            # simple name with no value (boolean, or _DEFAULT)
colas@0
   132
            elsif ( $string =~ s/^$sep*([a-z]\w*)\b//is ) {
colas@0
   133
                my $key = $1;
colas@0
   134
                $this->{$key} = 1;
colas@0
   135
            }
colas@0
   136
            # otherwise the whole string - sans padding - is the default
colas@0
   137
            else {
colas@0
   138
                if( $string =~ m/^\s*(.*?)\s*$/s &&
colas@0
   139
                      !defined($this->{$DEFAULTKEY})) {
colas@0
   140
                    $this->{$DEFAULTKEY} = $1;
colas@0
   141
                }
colas@0
   142
                last;
colas@0
   143
            }
colas@0
   144
        } elsif( $string =~ m/^\s*(.*?)\s*$/s ) {
colas@0
   145
            $this->{$DEFAULTKEY} = $1 if( $first );
colas@0
   146
            last;
colas@0
   147
        }
colas@0
   148
    }
colas@0
   149
    foreach my $k ( keys %$this ) {
colas@0
   150
        $this->{$k} =~ s/$TWiki::TranslationToken(\d\d)/chr($1)/geo;  # escapes
colas@0
   151
    }
colas@0
   152
    return $this;
colas@0
   153
}
colas@0
   154
colas@0
   155
=pod
colas@0
   156
colas@0
   157
---++ ObjectMethod isEmpty() -> boolean
colas@0
   158
colas@0
   159
Return false if attribute set is not empty.
colas@0
   160
colas@0
   161
=cut
colas@0
   162
colas@0
   163
sub isEmpty {
colas@0
   164
  my $this = shift;
colas@0
   165
colas@0
   166
colas@0
   167
  foreach my $k ( keys %$this ) {
colas@0
   168
      return 0 if $k ne $RAWKEY;
colas@0
   169
  }
colas@0
   170
  return 1;
colas@0
   171
}
colas@0
   172
colas@0
   173
=pod
colas@0
   174
colas@0
   175
---++ ObjectMethod remove($key) -> $value
colas@0
   176
colas@0
   177
   * =$key= - Attribute to remove
colas@0
   178
Remove an attr value from the map, return old value. After a call to
colas@0
   179
=remove= the attribute is no longer defined.
colas@0
   180
colas@0
   181
=cut
colas@0
   182
colas@0
   183
sub remove {
colas@0
   184
  my ( $this, $attr ) = @_;
colas@0
   185
  my $val = $this->{$attr};
colas@0
   186
  delete( $this->{$attr} ) if ( exists $this->{$attr} );
colas@0
   187
  return $val;
colas@0
   188
}
colas@0
   189
colas@0
   190
=pod
colas@0
   191
colas@0
   192
---++ ObjectMethod stringify() -> $string
colas@0
   193
colas@0
   194
Generate a printed form for the map, using strict
colas@0
   195
attribute syntax, with only the single-quote extension
colas@0
   196
syntax observed (no {} brackets, though).
colas@0
   197
colas@0
   198
=cut
colas@0
   199
colas@0
   200
sub stringify {
colas@0
   201
  my $this = shift;
colas@0
   202
  my $key;
colas@0
   203
  my @ss;
colas@0
   204
  foreach $key ( sort keys %$this ) {
colas@0
   205
	if ( $key ne $ERRORKEY && $key ne $RAWKEY ) {
colas@0
   206
	  my $es = ( $key eq $DEFAULTKEY ) ? '' : $key.'=';
colas@0
   207
	  my $val = $this->{$key};
colas@0
   208
      $val =~ s/"/\\"/g;
colas@0
   209
      push( @ss, $es.'"'.$val.'"' );
colas@0
   210
	}
colas@0
   211
  }
colas@0
   212
  return join( ' ', @ss );
colas@0
   213
}
colas@0
   214
colas@0
   215
colas@0
   216
# ---++ StaticMethod extractValue() -> $string
colas@0
   217
#
colas@0
   218
# Legacy support, formerly known as extractNameValuePair. This
colas@0
   219
# static method uses context information to determine how a value
colas@0
   220
# string is to be parsed. For example, if you have an attribute string
colas@0
   221
# like this:
colas@0
   222
#
colas@0
   223
# "abc def="ghi" jkl" def="qqq"
colas@0
   224
#
colas@0
   225
# then call extractValue( "def" ), it will return "ghi".
colas@0
   226
colas@0
   227
sub extractValue {
colas@0
   228
    my( $str, $name ) = @_;
colas@0
   229
colas@0
   230
    my $value = '';
colas@0
   231
    return $value unless( $str );
colas@0
   232
    $str =~ s/\\\"/\\$TWiki::TranslationToken/g;  # escape \"
colas@0
   233
colas@0
   234
    if( $name ) {
colas@0
   235
        # format is: %VAR{ ... name = "value" }%
colas@0
   236
        if( $str =~ /(^|[^\S])$name\s*=\s*\"([^\"]*)\"/ ) {
colas@0
   237
            $value = $2 if defined $2;  # distinguish between '' and "0"
colas@0
   238
        }
colas@0
   239
colas@0
   240
    } else {
colas@0
   241
        # test if format: { "value" ... }
colas@0
   242
        if( $str =~ /(^|\=\s*\"[^\"]*\")\s*\"(.*?)\"\s*(\w+\s*=\s*\"|$)/ ) {
colas@0
   243
            # is: %VAR{ "value" }%
colas@0
   244
            # or: %VAR{ "value" param="etc" ... }%
colas@0
   245
            # or: %VAR{ ... = "..." "value" ... }%
colas@0
   246
            # Note: "value" may contain embedded double quotes
colas@0
   247
            $value = $2 if defined $2;  # distinguish between '' and "0";
colas@0
   248
colas@0
   249
        } elsif( ( $str =~ /^\s*\w+\s*=\s*\"([^\"]*)/ ) && ( $1 ) ) {
colas@0
   250
            # is: %VAR{ name = "value" }%
colas@0
   251
            # do nothing, is not a standalone var
colas@0
   252
colas@0
   253
        } else {
colas@0
   254
            # format is: %VAR{ value }%
colas@0
   255
            $value = $str;
colas@0
   256
        }
colas@0
   257
    }
colas@0
   258
    $value =~ s/\\$TWiki::TranslationToken/\"/go;  # resolve \"
colas@0
   259
    return $value;
colas@0
   260
}
colas@0
   261
colas@0
   262
# ---++ ObjectMethod get($key) -> $value
colas@0
   263
#
colas@0
   264
# | $key | Attribute to get |
colas@0
   265
# Get an attr value from the map.
colas@0
   266
#
colas@0
   267
# Synonymous with $attrs->{$key}. Retained mainly for compatibility with
colas@0
   268
# the old AttrsContrib.
colas@0
   269
sub get {
colas@0
   270
    my( $this, $field) = @_;
colas@0
   271
    return $this->{$field};
colas@0
   272
}
colas@0
   273
colas@0
   274
1;