111 lines
2.0 KiB
Perl
111 lines
2.0 KiB
Perl
|
package attr;
|
|||
|
|
|
|||
|
|
use locale;
|
|||
|
|
use strict;
|
|||
|
|
|
|||
|
|
|
|||
|
|
sub match(\@\@)
|
|||
|
|
{
|
|||
|
|
my ($cat1,$avs1)= @{shift @_};
|
|||
|
|
my ($cat2,$avs2)= @{shift @_};
|
|||
|
|
|
|||
|
|
if($cat1 ne $cat2)
|
|||
|
|
{
|
|||
|
|
return 0;
|
|||
|
|
}
|
|||
|
|
else
|
|||
|
|
{
|
|||
|
|
ATTR:for my $attr (keys %$avs1)
|
|||
|
|
{
|
|||
|
|
if($avs2->{$attr})
|
|||
|
|
{
|
|||
|
|
for my $val (keys %{$avs1->{$attr}})
|
|||
|
|
{
|
|||
|
|
next ATTR if $avs2->{$attr}->{$val};
|
|||
|
|
}
|
|||
|
|
return 0;
|
|||
|
|
last ATTR;
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
return 1;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
# funkcja parse
|
|||
|
|
# arg: deskrypcja
|
|||
|
|
# warto<74><6F>: referencja do tablicy [<cat>, <avs>],
|
|||
|
|
# gdzie <avs> jest referencja do hasza, zawierajacego pary
|
|||
|
|
# atrybut=>hasz warto<74>ci (pary warto<74><6F>=>1), czyli np.
|
|||
|
|
|
|||
|
|
# [
|
|||
|
|
# 'ADJ',
|
|||
|
|
# {
|
|||
|
|
# 'KOLEDZY' => {
|
|||
|
|
# '<alojzy>' => 1,
|
|||
|
|
# '<karol>' => 1,
|
|||
|
|
# '<jan>' => 1
|
|||
|
|
# },
|
|||
|
|
# 'C' => {
|
|||
|
|
# 'p' => 1,
|
|||
|
|
# 'a' => 1,
|
|||
|
|
# 'i' => 1
|
|||
|
|
# },
|
|||
|
|
# 'N' => {
|
|||
|
|
# 'p' => 1
|
|||
|
|
# }
|
|||
|
|
# }
|
|||
|
|
# ];
|
|||
|
|
|
|||
|
|
sub parse ($)
|
|||
|
|
{
|
|||
|
|
my ($dstr)=@_;
|
|||
|
|
my $avs={};
|
|||
|
|
my ($cat,$attrlist) = split '/', $dstr;
|
|||
|
|
attr:
|
|||
|
|
while( $attrlist =~ /([[:upper:]]+)((?:[[:lower:]+?!*-]|<[^>\n]+>)+)/g )
|
|||
|
|
{
|
|||
|
|
my ($attrstr,$valstr)=($1,$2);
|
|||
|
|
my %vals;
|
|||
|
|
while($valstr =~ /[[:lower:]+?!*-]|<[^>\n]+>/g)
|
|||
|
|
{
|
|||
|
|
my $val = $&;
|
|||
|
|
next attr if $val eq '*';
|
|||
|
|
$val =~ s/^<([[:lower:]])>$/$1/;
|
|||
|
|
$vals{$val}=1;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
$avs->{$attrstr} = \%vals; # dlaczego to dziala? %vals jest lokalne
|
|||
|
|
}
|
|||
|
|
[$cat, $avs];
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
# funkcja unparse
|
|||
|
|
# arg: jak warto<74><6F> parse
|
|||
|
|
# warto<74><6F>: deskrypcja - napis
|
|||
|
|
|
|||
|
|
sub unparse (\@)
|
|||
|
|
{
|
|||
|
|
my ($cat,$avs)= @{shift @_};
|
|||
|
|
my $dstr=$cat;
|
|||
|
|
my @attrs = keys %$avs;
|
|||
|
|
if(@attrs)
|
|||
|
|
{
|
|||
|
|
$dstr .= '/';
|
|||
|
|
for my $attr ( sort @attrs )
|
|||
|
|
{
|
|||
|
|
$dstr .= $attr . (join '', sort keys %{$avs->{$attr}});
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
$dstr;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
sub canonize ($)
|
|||
|
|
{
|
|||
|
|
unparse @{parse @_[0]} ;
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
1;
|