Whatpm/CSS/SelectorsSerializer.pm

package Whatpm::CSS::SelectorsSerializer;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

use Whatpm::CSS::SelectorsParser qw(:selector :combinator :match);

sub serialize_test ($$;$) {
  my (undef, $selectors, $lookup_prefix) = @_;
  my $i = 0;
  my $ident = sub {
    my $s = shift;
    $s =~ s{([^A-Za-z_0-9\x80-\x{D7FF}\x{E000}-\x{10FFFF}-])}{
      my $v = ord $1;
      sprintf '\\%06X',$v > 0x10FFFF ? 0xFFFFFF : $v;
    }ge;
    $s =~ s/^([0-9])/\\00003$1/g;
    $s =~ s/^-([^A-Za-z\x80-\x{D7FF}\x{E000}-\x{10FFFF}_])/\\00002D$1/g;
    $s = '\\00002D' if $s eq '-';
    return $s;
  }; # $ident
  my $str = sub {
    my $s = shift;
    $s =~ s{([^\x20\x21\x23-\x5B\x5D-\x{D7FF}\x{E000}-\x{10FFFF}])}{
      my $v = ord $1;
      sprintf '\\%06X',$v > 0x10FFFF ? 0xFFFFFF : $v;
    }ge;
    return '"'.$s.'"';
  }; # $str

  my $lp = $lookup_prefix ? sub {
    my $v = $lookup_prefix->($_[0]);
    return $ident->(defined $v ? $v : $_[0]);
  } : $ident; # $lp

  my $r = join ",\n", map {
    join "", map {
      if (ref $_) {
        my $ss = [];
        $ss->[LOCAL_NAME_SELECTOR] = [LOCAL_NAME_SELECTOR, undef];
        for my $s (@$_) {
          if ($s->[0] == NAMESPACE_SELECTOR or
              $s->[0] == LOCAL_NAME_SELECTOR) {
            $ss->[$s->[0]] = $s;
          } else {
            push @{$ss->[$s->[0]] ||= []}, $s;
          }
        }
        
        my $v = '';
        if (not defined $ss->[NAMESPACE_SELECTOR]) {
          $v .= '*|';
        } elsif (defined $ss->[NAMESPACE_SELECTOR]->[1]) {
          $v .= $lp->($ss->[NAMESPACE_SELECTOR]->[1]) . '|';
        } else {
          $v .= '|';
        }

        if (defined $ss->[LOCAL_NAME_SELECTOR]->[1]) {
          $v .= $ident->($ss->[LOCAL_NAME_SELECTOR]->[1]);
        } else {
          $v .= '*';
        }

        $v .= join '', sort {$a cmp $b} map {
          '[' .
          (defined $_->[1] ?
            $_->[1] eq '' ? '' : $lp->($_->[1]) : '*') .
          '|' .
          $ident->($_->[2]) .
          ($_->[3] != EXISTS_MATCH ?
            {EQUALS_MATCH, '=',
             INCLUDES_MATCH, '~=',
             DASH_MATCH, '|=',
             PREFIX_MATCH, '^=',
             SUFFIX_MATCH, '$=',
             SUBSTRING_MATCH, '*='}->{$_->[3]} .
            $str->($_->[4])
          : '') .
          ']';
        } @{$ss->[ATTRIBUTE_SELECTOR] || []};

        $v .= join '', sort {$a cmp $b} map {
          '.' . $ident->($_->[1]);
        } @{$ss->[CLASS_SELECTOR] || []};

        $v .= join '', sort {$a cmp $b} map {
          '#' . $ident->($_->[1]);
        } @{$ss->[ID_SELECTOR] || []};

        $v .= join '', sort {$a cmp $b} map {
          my $v = $_;
          if ($v->[1] eq 'lang') {
            ':lang(' . $ident->($v->[2]) . ')';
          } elsif ($v->[1] eq 'not') {
            my $v = Whatpm::CSS::SelectorsSerializer->serialize_test
                ([[DESCENDANT_COMBINATOR, [@{$v}[2..$#{$v}]]]]);
            $v =~ s/^    \*\|\*(?!$)/    /;
            ":not(\n    " . $v . "    )";
          } elsif ({'nth-child' => 1,
                    'nth-last-child' => 1,
                    'nth-of-type' => 1,
                    'nth-last-of-type' => 1}->{$v->[1]}) {
            ':' . $ident->($v->[1]) . '(' .
            ($v->[2] . 'n' . ($v->[3] < 0 ? $v->[3] : '+' . $v->[3])) . ')';
          } elsif ($v->[1] eq '-manakai-contains') {
            ':-manakai-contains(' . $str->($v->[2]) . ')';
          } else {
            ':' . $ident->($v->[1]);
          }
        } @{$ss->[PSEUDO_CLASS_SELECTOR] || []};

        $v .= join '', sort {$a cmp $b} map {
          '::' . $ident->($_->[1]);
        } @{$ss->[PSEUDO_ELEMENT_SELECTOR] || []};

        $v . "\n";
      } else {
        "  " . {
          DESCENDANT_COMBINATOR, ' ',
          CHILD_COMBINATOR, '>',
          ADJACENT_SIBLING_COMBINATOR, '+',
          GENERAL_SIBLING_COMBINATOR, '~',
        }->{$_} . " ";
      }
    } @$_;
  } @$selectors;  

  return $r;
} # serialize_test

sub serialize_selector_text ($$;$) {
  my (undef, $selectors, $lookup_prefix) = @_;
  my $i = 0;
  my $ident = sub { $_[0] };
  my $str = sub { '"' . $_[0] . '"' };

  ## TODO: namespace prefix <http://suika.fam.cx/gate/2005/sw/namespace>

  my $lp = $lookup_prefix ? sub {
    my $v = $lookup_prefix->($_[0]);
    return $ident->(defined $v ? $v : $_[0]);
  } : $ident; # $lp

  my $r = join ", ", map {
    join "", map {
      if (ref $_) {
        my $ns_selector;
        my $ln_selector = [LOCAL_NAME_SELECTOR, undef];
        my $ss = [];
        for my $s (@$_) {
          if ($s->[0] == NAMESPACE_SELECTOR) {
            $ns_selector = $s;
          } elsif ($s->[0] == LOCAL_NAME_SELECTOR) {
            $ln_selector = $s;
          } else {
            push @$ss, $s;
          }
        }
        
        my $v = '';
        if (not defined $ns_selector) {
          $v .= '*|';
        } elsif (defined $ns_selector->[1]) {
          $v .= $lp->($ns_selector->[1]) . '|';
        } else {
          $v .= '|';
        }

        if (defined $ln_selector->[1]) {
          $v .= $ident->($ln_selector->[1]);
        } else {
          $v .= '*';
        }

        for (@$ss) {
          if ($_->[0] == ATTRIBUTE_SELECTOR) {
            $v .= '[' .
            (defined $_->[1] ?
              $_->[1] eq '' ? '' : $lp->($_->[1]) : '*') .
            '|' .
            $ident->($_->[2]) .
            ($_->[3] != EXISTS_MATCH ?
              {EQUALS_MATCH, '=',
               INCLUDES_MATCH, '~=',
               DASH_MATCH, '|=',
               PREFIX_MATCH, '^=',
               SUFFIX_MATCH, '$=',
               SUBSTRING_MATCH, '*='}->{$_->[3]} .
              $str->($_->[4])
            : '') .
            ']';
          } elsif ($_->[0] == CLASS_SELECTOR) {
            $v .= '.' . $ident->($_->[1]);
          } elsif ($_->[0] == ID_SELECTOR) {
            $v .= '#' . $ident->($_->[1]);
          } elsif ($_->[0] == PSEUDO_CLASS_SELECTOR) {
            my $vv = $_;
            if ($vv->[1] eq 'lang') {
              ':lang(' . $ident->($vv->[2]) . ')';
            } elsif ($vv->[1] eq 'not') {
              my $vvv = Whatpm::CSS::SelectorsSerializer
                  ->serialize_selector_text
                  ([[DESCENDANT_COMBINATOR, [@{$vv}[2..$#{$vv}]]]]);
              $vvv =~ s/^\*\|\*(?!$)//;
              $v .= ":not(" . $vvv . ")";
            } elsif ({'nth-child' => 1,
                      'nth-last-child' => 1,
                      'nth-of-type' => 1,
                      'nth-last-of-type' => 1}->{$vv->[1]}) {
              ## TODO: We should copy what new versions of browsers do.
              $v .= ':' . $ident->($vv->[1]) . '(' .
                  ($vv->[2] . 'n' .
                  ($vv->[3] < 0 ? $vv->[3] : '+' . $vv->[3])) . ')';
            } elsif ($vv->[1] eq '-manakai-contains') {
              $v .= ':-manakai-contains(' . $str->($vv->[2]) . ')';
            } else {
              $v .= ':' . $ident->($vv->[1]);
            }
          } elsif ($_->[0] == PSEUDO_ELEMENT_SELECTOR) {
            $v .= '::' . $ident->($_->[1]);
          }
          ## NOTE: else ... impl error

        }
        $v;
      } else {
        {
          DESCENDANT_COMBINATOR, ' ',
          CHILD_COMBINATOR, ' > ',
          ADJACENT_SIBLING_COMBINATOR, ' + ',
          GENERAL_SIBLING_COMBINATOR, ' ~ ',
        }->{$_};
      }
    } @$_[1..$#$_];
  } @$selectors;  

  return $r;
} # serialize_selector_text

=head1 LICENSE

Copyright 2007-2008 Wakaba <w@suika.fam.cx>

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;
# $Date: 2007/12/23 15:47:09 $
1	wakaba	1.1	package Whatpm::CSS::SelectorsSerializer;
2			use strict;
3	wakaba	1.7	our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.1
5			use Whatpm::CSS::SelectorsParser qw(:selector :combinator :match);
6
7	wakaba	1.6	sub serialize_test ($$;$) {
8			my (undef, $selectors, $lookup_prefix) = @_;
9	wakaba	1.1	my $i = 0;
10			my $ident = sub {
11			my $s = shift;
12			$s =~ s{([^A-Za-z_0-9\x80-\x{D7FF}\x{E000}-\x{10FFFF}-])}{
13			my $v = ord $1;
14			sprintf '\\%06X',$v > 0x10FFFF ? 0xFFFFFF : $v;
15			}ge;
16			$s =~ s/^([0-9])/\\00003$1/g;
17	wakaba	1.4	$s =~ s/^-([^A-Za-z\x80-\x{D7FF}\x{E000}-\x{10FFFF}_])/\\00002D$1/g;
18			$s = '\\00002D' if $s eq '-';
19	wakaba	1.1	return $s;
20	wakaba	1.4	}; # $ident
21	wakaba	1.1	my $str = sub {
22			my $s = shift;
23			$s =~ s{([^\x20\x21\x23-\x5B\x5D-\x{D7FF}\x{E000}-\x{10FFFF}])}{
24			my $v = ord $1;
25			sprintf '\\%06X',$v > 0x10FFFF ? 0xFFFFFF : $v;
26			}ge;
27			return '"'.$s.'"';
28			}; # $str
29	wakaba	1.6
30			my $lp = $lookup_prefix ? sub {
31			my $v = $lookup_prefix->($_[0]);
32			return $ident->(defined $v ? $v : $_[0]);
33			} : $ident; # $lp
34
35	wakaba	1.1	my $r = join ",\n", map {
36			join "", map {
37			if (ref $_) {
38			my $ss = [];
39			$ss->[LOCAL_NAME_SELECTOR] = [LOCAL_NAME_SELECTOR, undef];
40			for my $s (@$_) {
41			if ($s->[0] == NAMESPACE_SELECTOR or
42			$s->[0] == LOCAL_NAME_SELECTOR) {
43			$ss->[$s->[0]] = $s;
44			} else {
45			push @{$ss->[$s->[0]] \|\|= []}, $s;
46			}
47			}
48
49			my $v = '';
50			if (not defined $ss->[NAMESPACE_SELECTOR]) {
51			$v .= '*\|';
52			} elsif (defined $ss->[NAMESPACE_SELECTOR]->[1]) {
53	wakaba	1.6	$v .= $lp->($ss->[NAMESPACE_SELECTOR]->[1]) . '\|';
54	wakaba	1.1	} else {
55			$v .= '\|';
56			}
57
58			if (defined $ss->[LOCAL_NAME_SELECTOR]->[1]) {
59			$v .= $ident->($ss->[LOCAL_NAME_SELECTOR]->[1]);
60			} else {
61			$v .= '*';
62			}
63
64			$v .= join '', sort {$a cmp $b} map {
65			'[' .
66			(defined $_->[1] ?
67	wakaba	1.6	$_->[1] eq '' ? '' : $lp->($_->[1]) : '*') .
68	wakaba	1.1	'\|' .
69			$ident->($_->[2]) .
70			($_->[3] != EXISTS_MATCH ?
71			{EQUALS_MATCH, '=',
72			INCLUDES_MATCH, '~=',
73			DASH_MATCH, '\|=',
74			PREFIX_MATCH, '^=',
75			SUFFIX_MATCH, '$=',
76			SUBSTRING_MATCH, '*='}->{$_->[3]} .
77			$str->($_->[4])
78			: '') .
79			']';
80			} @{$ss->[ATTRIBUTE_SELECTOR] \|\| []};
81
82			$v .= join '', sort {$a cmp $b} map {
83			'.' . $ident->($_->[1]);
84			} @{$ss->[CLASS_SELECTOR] \|\| []};
85
86			$v .= join '', sort {$a cmp $b} map {
87			'#' . $ident->($_->[1]);
88			} @{$ss->[ID_SELECTOR] \|\| []};
89
90			$v .= join '', sort {$a cmp $b} map {
91			my $v = $_;
92			if ($v->[1] eq 'lang') {
93			':lang(' . $ident->($v->[2]) . ')';
94			} elsif ($v->[1] eq 'not') {
95			my $v = Whatpm::CSS::SelectorsSerializer->serialize_test
96	wakaba	1.5	([[DESCENDANT_COMBINATOR, [@{$v}[2..$#{$v}]]]]);
97	wakaba	1.1	$v =~ s/^ \\\|\(?!$)/ /;
98			":not(\n " . $v . " )";
99			} elsif ({'nth-child' => 1,
100			'nth-last-child' => 1,
101			'nth-of-type' => 1,
102			'nth-last-of-type' => 1}->{$v->[1]}) {
103			':' . $ident->($v->[1]) . '(' .
104			($v->[2] . 'n' . ($v->[3] < 0 ? $v->[3] : '+' . $v->[3])) . ')';
105	wakaba	1.2	} elsif ($v->[1] eq '-manakai-contains') {
106			':-manakai-contains(' . $str->($v->[2]) . ')';
107	wakaba	1.1	} else {
108			':' . $ident->($v->[1]);
109			}
110			} @{$ss->[PSEUDO_CLASS_SELECTOR] \|\| []};
111
112			$v .= join '', sort {$a cmp $b} map {
113			'::' . $ident->($_->[1]);
114			} @{$ss->[PSEUDO_ELEMENT_SELECTOR] \|\| []};
115
116			$v . "\n";
117			} else {
118			" " . {
119			DESCENDANT_COMBINATOR, ' ',
120			CHILD_COMBINATOR, '>',
121			ADJACENT_SIBLING_COMBINATOR, '+',
122			GENERAL_SIBLING_COMBINATOR, '~',
123			}->{$_} . " ";
124			}
125			} @$_;
126			} @$selectors;
127
128	wakaba	1.5	return $r;
129	wakaba	1.1	} # serialize_test
130
131	wakaba	1.7	sub serialize_selector_text ($$;$) {
132			my (undef, $selectors, $lookup_prefix) = @_;
133			my $i = 0;
134			my $ident = sub { $_[0] };
135			my $str = sub { '"' . $_[0] . '"' };
136
137			## TODO: namespace prefix <http://suika.fam.cx/gate/2005/sw/namespace>
138
139			my $lp = $lookup_prefix ? sub {
140			my $v = $lookup_prefix->($_[0]);
141			return $ident->(defined $v ? $v : $_[0]);
142			} : $ident; # $lp
143
144			my $r = join ", ", map {
145			join "", map {
146			if (ref $_) {
147			my $ns_selector;
148			my $ln_selector = [LOCAL_NAME_SELECTOR, undef];
149			my $ss = [];
150			for my $s (@$_) {
151			if ($s->[0] == NAMESPACE_SELECTOR) {
152			$ns_selector = $s;
153			} elsif ($s->[0] == LOCAL_NAME_SELECTOR) {
154			$ln_selector = $s;
155			} else {
156			push @$ss, $s;
157			}
158			}
159
160			my $v = '';
161			if (not defined $ns_selector) {
162			$v .= '*\|';
163			} elsif (defined $ns_selector->[1]) {
164			$v .= $lp->($ns_selector->[1]) . '\|';
165			} else {
166			$v .= '\|';
167			}
168
169			if (defined $ln_selector->[1]) {
170			$v .= $ident->($ln_selector->[1]);
171			} else {
172			$v .= '*';
173			}
174
175			for (@$ss) {
176			if ($_->[0] == ATTRIBUTE_SELECTOR) {
177			$v .= '[' .
178			(defined $_->[1] ?
179			$_->[1] eq '' ? '' : $lp->($_->[1]) : '*') .
180			'\|' .
181			$ident->($_->[2]) .
182			($_->[3] != EXISTS_MATCH ?
183			{EQUALS_MATCH, '=',
184			INCLUDES_MATCH, '~=',
185			DASH_MATCH, '\|=',
186			PREFIX_MATCH, '^=',
187			SUFFIX_MATCH, '$=',
188			SUBSTRING_MATCH, '*='}->{$_->[3]} .
189			$str->($_->[4])
190			: '') .
191			']';
192			} elsif ($_->[0] == CLASS_SELECTOR) {
193			$v .= '.' . $ident->($_->[1]);
194			} elsif ($_->[0] == ID_SELECTOR) {
195			$v .= '#' . $ident->($_->[1]);
196			} elsif ($_->[0] == PSEUDO_CLASS_SELECTOR) {
197			my $vv = $_;
198			if ($vv->[1] eq 'lang') {
199			':lang(' . $ident->($vv->[2]) . ')';
200			} elsif ($vv->[1] eq 'not') {
201			my $vvv = Whatpm::CSS::SelectorsSerializer
202			->serialize_selector_text
203			([[DESCENDANT_COMBINATOR, [@{$vv}[2..$#{$vv}]]]]);
204			$vvv =~ s/^\\\|\(?!$)//;
205			$v .= ":not(" . $vvv . ")";
206			} elsif ({'nth-child' => 1,
207			'nth-last-child' => 1,
208			'nth-of-type' => 1,
209			'nth-last-of-type' => 1}->{$vv->[1]}) {
210			## TODO: We should copy what new versions of browsers do.
211			$v .= ':' . $ident->($vv->[1]) . '(' .
212			($vv->[2] . 'n' .
213			($vv->[3] < 0 ? $vv->[3] : '+' . $vv->[3])) . ')';
214			} elsif ($vv->[1] eq '-manakai-contains') {
215			$v .= ':-manakai-contains(' . $str->($vv->[2]) . ')';
216			} else {
217			$v .= ':' . $ident->($vv->[1]);
218			}
219			} elsif ($_->[0] == PSEUDO_ELEMENT_SELECTOR) {
220			$v .= '::' . $ident->($_->[1]);
221			}
222			## NOTE: else ... impl error
223
224			}
225			$v;
226			} else {
227			{
228			DESCENDANT_COMBINATOR, ' ',
229			CHILD_COMBINATOR, ' > ',
230			ADJACENT_SIBLING_COMBINATOR, ' + ',
231			GENERAL_SIBLING_COMBINATOR, ' ~ ',
232			}->{$_};
233			}
234			} @$_[1..$#$_];
235			} @$selectors;
236
237			return $r;
238			} # serialize_selector_text
239
240	wakaba	1.3	=head1 LICENSE
241
242	wakaba	1.7	Copyright 2007-2008 Wakaba <w@suika.fam.cx>
243	wakaba	1.3
244			This library is free software; you can redistribute it
245			and/or modify it under the same terms as Perl itself.
246
247			=cut
248
249	wakaba	1.1	1;
250	wakaba	1.7	# $Date: 2007/12/23 15:47:09 $