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