Whatpm/CSS/SelectorsSerializer.pm

package Whatpm::CSS::SelectorsSerializer;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.7 $=~/\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, $nsmap) = @_;
  my $i = 0;
  my $ident = sub { $_[0] };
  my $str = sub { '"' . $_[0] . '"' };

  ## NOTE: See <http://suika.fam.cx/gate/2005/sw/namespace> for browser
  ## implementation issues.

  my $r = join ", ", map {
    join "", map {
      if (ref $_) {
        my $ns_selector;
        my $ln_selector;
        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 .= '*|' if $nsmap->{has_namespace} and
              (not @$ss or defined $ln_selector);
        } elsif (defined $ns_selector->[1]) {
          my $list = $nsmap->{uri_to_prefixes}->{$ns_selector->[1]};
          if ($list and @$list) {
            $v .= $list->[0];
            ## NOTE: It might be empty; it might not be an IDENT followed
            ## by a '|' character.
          } else {
            #$v .= '';
          }
        } else {
          $v .= '|';
        }

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

        for (@$ss) {
          if ($_->[0] == ATTRIBUTE_SELECTOR) {
            $v .= '[';
            if (defined $_->[1]) {
              if ($_->[1] eq '') {
                #$v .= '|';
              } else {
                my $list = $nsmap->{uri_to_prefixes}->{$ns_selector->[1]};
                if ($list and @$list) {
                  $v .= $list->[0];
                  ## NOTE: It might be empty; it might not be an IDENT followed
                  ## by a '|' character.
                } else {
                  #$v .= '';
                }
              }
            } else {
              $v .= '*|';
            }
            $v .= $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 <[email protected]>

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

=cut

1;
# $Date: 2008/01/14 03:54:45 $
1	package Whatpm::CSS::SelectorsSerializer;
2	use strict;
3	our $VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4
5	use Whatpm::CSS::SelectorsParser qw(:selector :combinator :match);
6
7	sub serialize_test ($$;$) {
8	my (undef, $selectors, $lookup_prefix) = @_;
9	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	$s =~ s/^-([^A-Za-z\x80-\x{D7FF}\x{E000}-\x{10FFFF}_])/\\00002D$1/g;
18	$s = '\\00002D' if $s eq '-';
19	return $s;
20	}; # $ident
21	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
30	my $lp = $lookup_prefix ? sub {
31	my $v = $lookup_prefix->($_[0]);
32	return $ident->(defined $v ? $v : $_[0]);
33	} : $ident; # $lp
34
35	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	$v .= $lp->($ss->[NAMESPACE_SELECTOR]->[1]) . '\|';
54	} 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	$_->[1] eq '' ? '' : $lp->($_->[1]) : '*') .
68	'\|' .
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	([[DESCENDANT_COMBINATOR, [@{$v}[2..$#{$v}]]]]);
97	$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	} elsif ($v->[1] eq '-manakai-contains') {
106	':-manakai-contains(' . $str->($v->[2]) . ')';
107	} 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	return $r;
129	} # serialize_test
130
131	sub serialize_selector_text ($$$) {
132	my (undef, $selectors, $nsmap) = @_;
133	my $i = 0;
134	my $ident = sub { $_[0] };
135	my $str = sub { '"' . $_[0] . '"' };
136
137	## NOTE: See <http://suika.fam.cx/gate/2005/sw/namespace> for browser
138	## implementation issues.
139
140	my $r = join ", ", map {
141	join "", map {
142	if (ref $_) {
143	my $ns_selector;
144	my $ln_selector;
145	my $ss = [];
146	for my $s (@$_) {
147	if ($s->[0] == NAMESPACE_SELECTOR) {
148	$ns_selector = $s;
149	} elsif ($s->[0] == LOCAL_NAME_SELECTOR) {
150	$ln_selector = $s;
151	} else {
152	push @$ss, $s;
153	}
154	}
155
156	my $v = '';
157	if (not defined $ns_selector) {
158	$v .= '*\|' if $nsmap->{has_namespace} and
159	(not @$ss or defined $ln_selector);
160	} elsif (defined $ns_selector->[1]) {
161	my $list = $nsmap->{uri_to_prefixes}->{$ns_selector->[1]};
162	if ($list and @$list) {
163	$v .= $list->[0];
164	## NOTE: It might be empty; it might not be an IDENT followed
165	## by a '\|' character.
166	} else {
167	#$v .= '';
168	}
169	} else {
170	$v .= '\|';
171	}
172
173	if (defined $ln_selector) {
174	$v .= $ident->($ln_selector->[1]);
175	} else {
176	$v .= '*' if not @$ss or length $v;
177	}
178
179	for (@$ss) {
180	if ($_->[0] == ATTRIBUTE_SELECTOR) {
181	$v .= '[';
182	if (defined $_->[1]) {
183	if ($_->[1] eq '') {
184	#$v .= '\|';
185	} else {
186	my $list = $nsmap->{uri_to_prefixes}->{$ns_selector->[1]};
187	if ($list and @$list) {
188	$v .= $list->[0];
189	## NOTE: It might be empty; it might not be an IDENT followed
190	## by a '\|' character.
191	} else {
192	#$v .= '';
193	}
194	}
195	} else {
196	$v .= '*\|';
197	}
198	$v .= $ident->($_->[2]) .
199	($_->[3] != EXISTS_MATCH ?
200	{EQUALS_MATCH, '=',
201	INCLUDES_MATCH, '~=',
202	DASH_MATCH, '\|=',
203	PREFIX_MATCH, '^=',
204	SUFFIX_MATCH, '$=',
205	SUBSTRING_MATCH, '*='}->{$_->[3]} .
206	$str->($_->[4])
207	: '') .
208	']';
209	} elsif ($_->[0] == CLASS_SELECTOR) {
210	$v .= '.' . $ident->($_->[1]);
211	} elsif ($_->[0] == ID_SELECTOR) {
212	$v .= '#' . $ident->($_->[1]);
213	} elsif ($_->[0] == PSEUDO_CLASS_SELECTOR) {
214	my $vv = $_;
215	if ($vv->[1] eq 'lang') {
216	':lang(' . $ident->($vv->[2]) . ')';
217	} elsif ($vv->[1] eq 'not') {
218	my $vvv = Whatpm::CSS::SelectorsSerializer
219	->serialize_selector_text
220	([[DESCENDANT_COMBINATOR, [@{$vv}[2..$#{$vv}]]]]);
221	$vvv =~ s/^\\\|\(?!$)//;
222	$v .= ":not(" . $vvv . ")";
223	} elsif ({'nth-child' => 1,
224	'nth-last-child' => 1,
225	'nth-of-type' => 1,
226	'nth-last-of-type' => 1}->{$vv->[1]}) {
227	## TODO: We should copy what new versions of browsers do.
228	$v .= ':' . $ident->($vv->[1]) . '(' .
229	($vv->[2] . 'n' .
230	($vv->[3] < 0 ? $vv->[3] : '+' . $vv->[3])) . ')';
231	} elsif ($vv->[1] eq '-manakai-contains') {
232	$v .= ':-manakai-contains(' . $str->($vv->[2]) . ')';
233	} else {
234	$v .= ':' . $ident->($vv->[1]);
235	}
236	} elsif ($_->[0] == PSEUDO_ELEMENT_SELECTOR) {
237	$v .= ':' . $ident->($_->[1]);
238	}
239	## NOTE: else ... impl error
240
241	}
242	$v;
243	} else {
244	{
245	DESCENDANT_COMBINATOR, ' ',
246	CHILD_COMBINATOR, ' > ',
247	ADJACENT_SIBLING_COMBINATOR, ' + ',
248	GENERAL_SIBLING_COMBINATOR, ' ~ ',
249	}->{$_};
250	}
251	} @$_[1..$#$_];
252	} @$selectors;
253
254	return $r;
255	} # serialize_selector_text
256
257	=head1 LICENSE
258
259	Copyright 2007-2008 Wakaba <[email protected]>
260
261	This library is free software; you can redistribute it
262	and/or modify it under the same terms as Perl itself.
263
264	=cut
265
266	1;
267	# $Date: 2008/01/14 03:54:45 $