291 lines
8.4 KiB
Perl
291 lines
8.4 KiB
Perl
|
# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
|
||
|
|
#
|
||
|
|
# Copyright (C) 1999-2007 TWiki Contributors. All Rights Reserved.
|
||
|
|
# TWiki Contributors are listed in the AUTHORS file in the root of
|
||
|
|
# this distribution. NOTE: Please extend that file, not this notice.
|
||
|
|
#
|
||
|
|
# Additional copyrights apply to some or all of the code in this
|
||
|
|
# file as follows:
|
||
|
|
# Derived from Contrib::Attrs, which is
|
||
|
|
# Copyright (C) 2001 Motorola - All rights reserved
|
||
|
|
#
|
||
|
|
# This program is free software; you can redistribute it and/or
|
||
|
|
# modify it under the terms of the GNU General Public License
|
||
|
|
# as published by the Free Software Foundation; either version 2
|
||
|
|
# of the License, or (at your option) any later version. For
|
||
|
|
# more details read LICENSE in the root of this distribution.
|
||
|
|
#
|
||
|
|
# This program is distributed in the hope that it will be useful,
|
||
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
||
|
|
#
|
||
|
|
# As per the GPL, removal of this notice is prohibited.
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---+ package TWiki::Attrs
|
||
|
|
|
||
|
|
Class of attribute sets, designed for parsing and storing attribute values
|
||
|
|
from a TWiki tag e.g. =%TAG{fred='bad' "sad" joe="mad"}%=
|
||
|
|
|
||
|
|
An attribute set is a map containing an entry for each parameter. The
|
||
|
|
default parameter (unnamed quoted string) is named <code>_<nop>DEFAULT</code> in the map.
|
||
|
|
|
||
|
|
Attributes declared later in the string will override those of the same
|
||
|
|
name defined earlier. The one exception to this is the _DEFAULT key, where
|
||
|
|
the _first_ instance of a setting is always taken.
|
||
|
|
|
||
|
|
As well as standard TWiki syntax (parameter values double-quoted)
|
||
|
|
it also parses single-quoted values, unquoted spaceless
|
||
|
|
values, spaces around the =, and commas as well as spaces separating values,
|
||
|
|
though none of these alternatives is advertised in documentation and
|
||
|
|
the extended syntax can be turned off by passing the 'strict' parameter
|
||
|
|
to =new=.
|
||
|
|
|
||
|
|
This class replaces the old TWiki::extractNameValuePair and
|
||
|
|
TWiki::extractParameters.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
package TWiki::Attrs;
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use Assert;
|
||
|
|
|
||
|
|
use vars qw( $ERRORKEY $DEFAULTKEY $RAWKEY );
|
||
|
|
|
||
|
|
$ERRORKEY = '_ERROR';
|
||
|
|
$DEFAULTKEY = '_DEFAULT';
|
||
|
|
$RAWKEY = '_RAW';
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ClassMethod new ($string, $friendly) => \%attrsObjectRef
|
||
|
|
|
||
|
|
* =$string= - String containing attribute specification
|
||
|
|
* =$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.
|
||
|
|
|
||
|
|
Parse a standard attribute string containing name=value pairs and create a new
|
||
|
|
attributes object. The value may be a word or a quoted string. If there is an
|
||
|
|
error during parsing, the parse will complete but $attrs->{_ERROR} will be
|
||
|
|
set in the new object. $attrs->{_RAW} will always contain the full unprocessed
|
||
|
|
$string.
|
||
|
|
|
||
|
|
Extended syntax example:
|
||
|
|
<verbatim>
|
||
|
|
my $attrs = new TWiki::Attrs('the="time \\"has come", "the walrus" said to=speak of=\'many \\'things\', 1);
|
||
|
|
</verbatim>
|
||
|
|
In this example:
|
||
|
|
* =the= will be =time "has come=
|
||
|
|
* <code>_<nop>_<nop>default__</code> will be =the walrus=
|
||
|
|
* =said= will be =on=
|
||
|
|
* =to= will be =speak=
|
||
|
|
* =of= will be =many 'things=
|
||
|
|
|
||
|
|
Only " and ' are escaped.
|
||
|
|
|
||
|
|
Traditional syntax is as old TWiki, except that the whole string is parsed
|
||
|
|
(the old parser would only recognise default values in position 1, nowhere
|
||
|
|
else)
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub new {
|
||
|
|
my ( $class, $string, $friendly ) = @_;
|
||
|
|
my $this = bless( {}, $class );
|
||
|
|
|
||
|
|
$this->{$RAWKEY} = $string;
|
||
|
|
|
||
|
|
return $this unless defined( $string );
|
||
|
|
|
||
|
|
$string =~ s/\\(["'])/$TWiki::TranslationToken.sprintf("%.2u", ord($1))/ge; # escapes
|
||
|
|
|
||
|
|
my $sep = ( $friendly ? "[\\s,]" : "\\s" );
|
||
|
|
my $first = 1;
|
||
|
|
|
||
|
|
if( !$friendly && $string =~ s/^\s*\"(.*?)\"\s*(\w+\s*=\s*\"|$)/$2/s ) {
|
||
|
|
$this->{$DEFAULTKEY} = $1;
|
||
|
|
}
|
||
|
|
while ( $string =~ m/\S/s ) {
|
||
|
|
# name="value" pairs
|
||
|
|
if ( $string =~ s/^$sep*(\w+)\s*=\s*\"(.*?)\"//is ) {
|
||
|
|
$this->{$1} = $2;
|
||
|
|
$first = 0;
|
||
|
|
}
|
||
|
|
# simple double-quoted value with no name, sets the default
|
||
|
|
elsif ( $string =~ s/^$sep*\"(.*?)\"//os ) {
|
||
|
|
$this->{$DEFAULTKEY} = $1
|
||
|
|
unless defined( $this->{$DEFAULTKEY} );
|
||
|
|
$first = 0;
|
||
|
|
}
|
||
|
|
elsif ( $friendly ) {
|
||
|
|
# name='value' pairs
|
||
|
|
if ( $string =~ s/^$sep*(\w+)\s*=\s*'(.*?)'//is ) {
|
||
|
|
$this->{$1} = $2;
|
||
|
|
}
|
||
|
|
# name=value pairs
|
||
|
|
elsif ( $string =~ s/^$sep*(\w+)\s*=\s*([^\s,\}\'\"]*)//is ) {
|
||
|
|
$this->{$1} = $2;
|
||
|
|
}
|
||
|
|
# simple single-quoted value with no name, sets the default
|
||
|
|
elsif ( $string =~ s/^$sep*'(.*?)'//os ) {
|
||
|
|
$this->{$DEFAULTKEY} = $1
|
||
|
|
unless defined( $this->{$DEFAULTKEY} );
|
||
|
|
}
|
||
|
|
# simple name with no value (boolean, or _DEFAULT)
|
||
|
|
elsif ( $string =~ s/^$sep*([a-z]\w*)\b//is ) {
|
||
|
|
my $key = $1;
|
||
|
|
$this->{$key} = 1;
|
||
|
|
}
|
||
|
|
# otherwise the whole string - sans padding - is the default
|
||
|
|
else {
|
||
|
|
if( $string =~ m/^\s*(.*?)\s*$/s &&
|
||
|
|
!defined($this->{$DEFAULTKEY})) {
|
||
|
|
$this->{$DEFAULTKEY} = $1;
|
||
|
|
}
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
} elsif( $string =~ m/^\s*(.*?)\s*$/s ) {
|
||
|
|
$this->{$DEFAULTKEY} = $1 if( $first );
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
foreach my $k ( keys %$this ) {
|
||
|
|
$this->{$k} =~ s/$TWiki::TranslationToken(\d\d)/chr($1)/geo; # escapes
|
||
|
|
}
|
||
|
|
return $this;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod isEmpty() -> boolean
|
||
|
|
|
||
|
|
Return false if attribute set is not empty.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub isEmpty {
|
||
|
|
my $this = shift;
|
||
|
|
|
||
|
|
ASSERT( $this->isa( 'TWiki::Attrs' )) if DEBUG;
|
||
|
|
|
||
|
|
foreach my $k ( keys %$this ) {
|
||
|
|
return 0 if $k ne $RAWKEY;
|
||
|
|
}
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod remove($key) -> $value
|
||
|
|
|
||
|
|
| $key | Attribute to remove |
|
||
|
|
Remove an attr value from the map, return old value. After a call to
|
||
|
|
=remove= the attribute is no longer defined.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub remove {
|
||
|
|
my ( $this, $attr ) = @_;
|
||
|
|
ASSERT($this->isa( 'TWiki::Attrs' )) if DEBUG;
|
||
|
|
my $val = $this->{$attr};
|
||
|
|
delete( $this->{$attr} ) if ( exists $this->{$attr} );
|
||
|
|
return $val;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod stringify() -> $string
|
||
|
|
|
||
|
|
Generate a printed form for the map, using standard
|
||
|
|
attribute syntax, with only the single-quote extension
|
||
|
|
syntax observed (no {} brackets, though).
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub stringify {
|
||
|
|
my $this = shift;
|
||
|
|
ASSERT($this->isa( 'TWiki::Attrs')) if DEBUG;
|
||
|
|
my $key;
|
||
|
|
my @ss;
|
||
|
|
foreach $key ( sort keys %$this ) {
|
||
|
|
if ( $key ne $ERRORKEY && $key ne $RAWKEY ) {
|
||
|
|
my $es = ( $key eq $DEFAULTKEY ) ? '' : $key.'=';
|
||
|
|
my $val = $this->{$key};
|
||
|
|
$val =~ s/"/\\"/g;
|
||
|
|
push( @ss, $es.'"'.$val.'"' );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return join( ' ', @ss );
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ StaticMethod extractValue() -> $string
|
||
|
|
|
||
|
|
Legacy support, formerly known as extractNameValuePair. This
|
||
|
|
static method uses context information to determine how a value
|
||
|
|
string is to be parsed. For example, if you have an attribute string
|
||
|
|
like this:
|
||
|
|
|
||
|
|
"abc def="ghi" jkl" def="qqq"
|
||
|
|
|
||
|
|
then call extractValue( "def" ), it will return "ghi".
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub extractValue {
|
||
|
|
my( $str, $name ) = @_;
|
||
|
|
|
||
|
|
my $value = '';
|
||
|
|
return $value unless( $str );
|
||
|
|
$str =~ s/\\\"/\\$TWiki::TranslationToken/g; # escape \"
|
||
|
|
|
||
|
|
if( $name ) {
|
||
|
|
# format is: %VAR{ ... name = "value" }%
|
||
|
|
if( $str =~ /(^|[^\S])$name\s*=\s*\"([^\"]*)\"/ ) {
|
||
|
|
$value = $2 if defined $2; # distinguish between '' and "0"
|
||
|
|
}
|
||
|
|
|
||
|
|
} else {
|
||
|
|
# test if format: { "value" ... }
|
||
|
|
if( $str =~ /(^|\=\s*\"[^\"]*\")\s*\"(.*?)\"\s*(\w+\s*=\s*\"|$)/ ) {
|
||
|
|
# is: %VAR{ "value" }%
|
||
|
|
# or: %VAR{ "value" param="etc" ... }%
|
||
|
|
# or: %VAR{ ... = "..." "value" ... }%
|
||
|
|
# Note: "value" may contain embedded double quotes
|
||
|
|
$value = $2 if defined $2; # distinguish between '' and "0";
|
||
|
|
|
||
|
|
} elsif( ( $str =~ /^\s*\w+\s*=\s*\"([^\"]*)/ ) && ( $1 ) ) {
|
||
|
|
# is: %VAR{ name = "value" }%
|
||
|
|
# do nothing, is not a standalone var
|
||
|
|
|
||
|
|
} else {
|
||
|
|
# format is: %VAR{ value }%
|
||
|
|
$value = $str;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$value =~ s/\\$TWiki::TranslationToken/\"/go; # resolve \"
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
=pod
|
||
|
|
|
||
|
|
---++ ObjectMethod get($key) -> $value
|
||
|
|
|
||
|
|
| $key | Attribute to get |
|
||
|
|
Get an attr value from the map.
|
||
|
|
|
||
|
|
Synonymous with $attrs->{$key}. Retained mainly for compatibility with
|
||
|
|
the old AttrsContrib.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub get {
|
||
|
|
my( $this, $field) = @_;
|
||
|
|
return $this->{$field};
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|