whatpm/Whatpm/mkhtmlparser.pl

#!/usr/bin/perl 
use strict;

my $DEBUG = $ENV{DEBUG};

while (<>) {
  s/!!!emit\b/return /;
  s{!!!next-input-character;}{q{
    if ($self->{char_buffer_pos} < length $self->{char_buffer}) {
      $self->{line_prev} = $self->{line};
      $self->{column_prev} = $self->{column};
      $self->{column}++;
      $self->{nc}
          = ord substr ($self->{char_buffer}, $self->{char_buffer_pos}++, 1);
    } else {
      $self->{set_nc}->($self);
    }
  }}ge;
  s{!!!nack\s*\(\s*'([^']+)'\s*\)\s*;}{
    ($DEBUG ? qq{
      if (\$self->{self_closing}) {
        !!!cp ('$1.2');
      } else {
        !!!cp ('$1.3');
      }
    } : '')
  }ge;
  s{!!!ack\s*(?>\([^)]*\)\s*)?;}{q{delete $self->{self_closing};}}ge;
  s{!!!ack-later\s*(?>\([^)]*\)\s*)?;}{}ge;
  s{!!!insert-element-f\s*\(([^(),]+),([^(),]+),([^(),]+),([^(),]+)\)\s*;}{qq{
    {
      my \$el;
      !!!create-element (\$el, $1, $2, $3, $4);
      \$insert->(\$el);
      push \@{\$self->{open_elements}}, [\$el, (\$el_category_f->{$1}->{$2} || 0) | FOREIGN_EL];

      if ($3\->{xmlns} and $3\->{xmlns}->{value} ne ($1)) {
        !!!parse-error (type => 'bad namespace', token => $4);
## TODO: Error type documentation
      }
      if ($3\->{'xmlns:xlink'} and
          $3\->{'xmlns:xlink'}->{value} ne q<http://www.w3.org/1999/xlink>) {
        !!!parse-error (type => 'bad namespace', token => $4);
      }
    }
  }}ge;
  s{!!!insert-element-t\s*\(([^(),]+),([^(),]+),([^(),]+)\)\s*;}{qq{
    {
      my \$el;
      !!!create-element (\$el, \$HTML_NS, $1, $2, $3);
      \$insert->(\$el);
      push \@{\$self->{open_elements}}, [\$el, \$el_category->{$1} || 0];
    }
  }}ge;
  s{!!!insert-element\s*\(([^(),]+),\s*,([^(),]+)\)\s*;}{qq{
    {
      my \$el;
      !!!create-element (\$el, \$HTML_NS, $1,, $2);
      \$self->{open_elements}->[-1]->[0]->append_child (\$el);
      push \@{\$self->{open_elements}}, [\$el, \$el_category->{$1} || 0];
    }
  }}ge;
  s{!!!insert-element\s*\(([^(),]+),([^(),]+),([^(),]+)\)\s*;}{qq{
    {
      my \$el;
      !!!create-element (\$el, \$HTML_NS, $1, $2, $3);
      \$self->{open_elements}->[-1]->[0]->append_child (\$el);
      push \@{\$self->{open_elements}}, [\$el, \$el_category->{$1} || 0];
    }
  }}ge;
  s{!!!create-element\s*\(([^(),]+),\s*([^(),]+),([^(),]+)(?:,([^(),]*)(?>,([^(),]+))?)?\)\s*;}{
    my ($l_var, $nsuri, $lname, $attrs, $token_var) = ($1, $2, $3, $4, $5);
    $nsuri =~ s/^\s+//;
    $nsuri =~ s/\s+\z//;
    my $r = qq{
      $l_var = \$self->{document}->create_element_ns
        ($nsuri, [undef, $lname]);
    };
    if (defined $attrs and length $attrs) {
      my $attr_xname;
      if ($nsuri eq q<$HTML_NS>) {
        $attr_xname = q[undef, [undef, $attr_name]];
      } else {
        ## NOTE: "Adjust SVG attributes" (SVG only),
        ## "adjust MathML attributes" (MathML only), and
        ## "adjust foreign attributes".
        $attr_xname = qq[
          \@{
            \$foreign_attr_xname->{\$attr_name} ||
            [undef, [undef,
                     ($nsuri) eq \$SVG_NS ?
                         (\$svg_attr_name->{\$attr_name} || \$attr_name) :
                     ($nsuri) eq \$MML_NS ?
                         (\$attr_name eq 'definitionurl' ?
                             'definitionURL' : \$attr_name) :
                         \$attr_name]]
          }
        ];
      }
      $r .= qq{
        for my \$attr_name (keys %{$attrs}) {
          my \$attr_t = $attrs\->{\$attr_name};
          my \$attr = \$self->{document}->create_attribute_ns ($attr_xname);
          \$attr->value (\$attr_t->{value});
          \$attr->set_user_data (manakai_source_line => \$attr_t->{line});
          \$attr->set_user_data (manakai_source_column => \$attr_t->{column});
          $l_var->set_attribute_node_ns (\$attr);
        }
      };
    }
    if (defined $token_var) {
      $token_var =~ s/^\s+//;
      $token_var =~ s/\s+$//;
      $r .= qq{
        $l_var->set_user_data (manakai_source_line => $token_var\->{line})
            if defined $token_var\->{line};
        $l_var->set_user_data (manakai_source_column => $token_var\->{column})
            if defined $token_var\->{column};
      };
      ## TODO: In future version, it should be allowed for an application
      ## developer to choose whether these information should be kept
      ## for tracking or not for performance by some means.
    }
    $r;
  }ge; # MUST
  s{!!!parse-error;}{q{$self->{parse_error}->();}}ge;
  s{!!!parse-error\s*\(}{
    q{$self->{parse_error}->(level => $self->{level}->{must}, }
  }ge;
  s{!!!next-token;}{q{$token = $self->_get_next_token;}}ge;
  s{!!!back-token;}{
    q{
      $token->{self_closing} = $self->{self_closing};
      unshift @{$self->{token}}, $token;
      delete $self->{self_closing};
    }
  }ge;
  s{!!!back-token\s*\(}{q{unshift @{$self->{token}}, (}}ge;
  s{!!!cp\s*\(\s*(\S+)\s*\)\s*;}{
    $DEBUG ? qq{
      #print STDERR "$1, ";
      \$Whatpm::HTML::Debug::cp_pass->($1) if \$Whatpm::HTML::Debug::cp_pass;
      BEGIN {
        \$Whatpm::HTML::Debug::cp->{$1} = 1;
      }
    } : ''
  }ge;
  print;
}
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3
4	wakaba	1.4	my $DEBUG = $ENV{DEBUG};
5
6	wakaba	1.1	while (<>) {
7			s/!!!emit\b/return /;
8			s{!!!next-input-character;}{q{
9	wakaba	1.16	if ($self->{char_buffer_pos} < length $self->{char_buffer}) {
10			$self->{line_prev} = $self->{line};
11			$self->{column_prev} = $self->{column};
12			$self->{column}++;
13	wakaba	1.17	$self->{nc}
14	wakaba	1.16	= ord substr ($self->{char_buffer}, $self->{char_buffer_pos}++, 1);
15			} else {
16	wakaba	1.17	$self->{set_nc}->($self);
17	wakaba	1.16	}
18	wakaba	1.1	}}ge;
19	wakaba	1.10	s{!!!nack\s\(\s'([^']+)'\s\)\s;}{
20			($DEBUG ? qq{
21			if (\$self->{self_closing}) {
22			!!!cp ('$1.2');
23			} else {
24			!!!cp ('$1.3');
25			}
26			} : '')
27			}ge;
28			s{!!!ack\s(?>\([^)]\)\s*)?;}{q{delete $self->{self_closing};}}ge;
29			s{!!!ack-later\s(?>\([^)]\)\s*)?;}{}ge;
30	wakaba	1.12	s{!!!insert-element-f\s\(([^(),]+),([^(),]+),([^(),]+),([^(),]+)\)\s;}{qq{
31	wakaba	1.7	{
32			my \$el;
33	wakaba	1.12	!!!create-element (\$el, $1, $2, $3, $4);
34	wakaba	1.7	\$insert->(\$el);
35	wakaba	1.12	push \@{\$self->{open_elements}}, [\$el, (\$el_category_f->{$1}->{$2} \|\| 0) \| FOREIGN_EL];
36
37			if ($3\->{xmlns} and $3\->{xmlns}->{value} ne ($1)) {
38			!!!parse-error (type => 'bad namespace', token => $4);
39			## TODO: Error type documentation
40			}
41	wakaba	1.19	if ($3\->{'xmlns:xlink'} and
42			$3\->{'xmlns:xlink'}->{value} ne q<http://www.w3.org/1999/xlink>) {
43			!!!parse-error (type => 'bad namespace', token => $4);
44			}
45	wakaba	1.7	}
46			}}ge;
47	wakaba	1.11	s{!!!insert-element-t\s\(([^(),]+),([^(),]+),([^(),]+)\)\s;}{qq{
48	wakaba	1.1	{
49			my \$el;
50	wakaba	1.11	!!!create-element (\$el, \$HTML_NS, $1, $2, $3);
51	wakaba	1.1	\$insert->(\$el);
52	wakaba	1.9	push \@{\$self->{open_elements}}, [\$el, \$el_category->{$1} \|\| 0];
53	wakaba	1.1	}
54			}}ge;
55	wakaba	1.7	s{!!!insert-element\s\(([^(),]+),\s,([^(),]+)\)\s*;}{qq{
56			{
57			my \$el;
58	wakaba	1.11	!!!create-element (\$el, \$HTML_NS, $1,, $2);
59	wakaba	1.7	\$self->{open_elements}->[-1]->[0]->append_child (\$el);
60	wakaba	1.9	push \@{\$self->{open_elements}}, [\$el, \$el_category->{$1} \|\| 0];
61	wakaba	1.7	}
62			}}ge;
63			s{!!!insert-element\s\(([^(),]+),([^(),]+),([^(),]+)\)\s;}{qq{
64			{
65			my \$el;
66	wakaba	1.11	!!!create-element (\$el, \$HTML_NS, $1, $2, $3);
67	wakaba	1.2	\$self->{open_elements}->[-1]->[0]->append_child (\$el);
68	wakaba	1.9	push \@{\$self->{open_elements}}, [\$el, \$el_category->{$1} \|\| 0];
69	wakaba	1.1	}
70			}}ge;
71	wakaba	1.12	s{!!!create-element\s\(([^(),]+),\s([^(),]+),([^(),]+)(?:,([^(),])(?>,([^(),]+))?)?\)\s;}{
72			my ($l_var, $nsuri, $lname, $attrs, $token_var) = ($1, $2, $3, $4, $5);
73			$nsuri =~ s/^\s+//;
74			$nsuri =~ s/\s+\z//;
75	wakaba	1.1	my $r = qq{
76	wakaba	1.7	$l_var = \$self->{document}->create_element_ns
77	wakaba	1.12	($nsuri, [undef, $lname]);
78	wakaba	1.1	};
79	wakaba	1.12	if (defined $attrs and length $attrs) {
80			my $attr_xname;
81			if ($nsuri eq q<$HTML_NS>) {
82			$attr_xname = q[undef, [undef, $attr_name]];
83			} else {
84	wakaba	1.14	## NOTE: "Adjust SVG attributes" (SVG only),
85			## "adjust MathML attributes" (MathML only), and
86	wakaba	1.12	## "adjust foreign attributes".
87			$attr_xname = qq[
88			\@{
89			\$foreign_attr_xname->{\$attr_name} \|\|
90			[undef, [undef,
91	wakaba	1.14	($nsuri) eq \$SVG_NS ?
92	wakaba	1.12	(\$svg_attr_name->{\$attr_name} \|\| \$attr_name) :
93	wakaba	1.14	($nsuri) eq \$MML_NS ?
94			(\$attr_name eq 'definitionurl' ?
95			'definitionURL' : \$attr_name) :
96	wakaba	1.12	\$attr_name]]
97			}
98			];
99			}
100	wakaba	1.1	$r .= qq{
101	wakaba	1.12	for my \$attr_name (keys %{$attrs}) {
102			my \$attr_t = $attrs\->{\$attr_name};
103			my \$attr = \$self->{document}->create_attribute_ns ($attr_xname);
104	wakaba	1.8	\$attr->value (\$attr_t->{value});
105			\$attr->set_user_data (manakai_source_line => \$attr_t->{line});
106			\$attr->set_user_data (manakai_source_column => \$attr_t->{column});
107			$l_var->set_attribute_node_ns (\$attr);
108	wakaba	1.1	}
109			};
110	wakaba	1.7	}
111	wakaba	1.12	if (defined $token_var) {
112	wakaba	1.7	$token_var =~ s/^\s+//;
113			$token_var =~ s/\s+$//;
114			$r .= qq{
115			$l_var->set_user_data (manakai_source_line => $token_var\->{line})
116			if defined $token_var\->{line};
117			$l_var->set_user_data (manakai_source_column => $token_var\->{column})
118			if defined $token_var\->{column};
119			};
120			## TODO: In future version, it should be allowed for an application
121			## developer to choose whether these information should be kept
122			## for tracking or not for performance by some means.
123	wakaba	1.1	}
124			$r;
125			}ge; # MUST
126	wakaba	1.12	s{!!!parse-error;}{q{$self->{parse_error}->();}}ge;
127			s{!!!parse-error\s*\(}{
128	wakaba	1.13	q{$self->{parse_error}->(level => $self->{level}->{must}, }
129	wakaba	1.12	}ge;
130	wakaba	1.1	s{!!!next-token;}{q{$token = $self->_get_next_token;}}ge;
131	wakaba	1.10	s{!!!back-token;}{
132			q{
133			$token->{self_closing} = $self->{self_closing};
134			unshift @{$self->{token}}, $token;
135			delete $self->{self_closing};
136			}
137			}ge;
138	wakaba	1.1	s{!!!back-token\s*\(}{q{unshift @{$self->{token}}, (}}ge;
139	wakaba	1.4	s{!!!cp\s\(\s(\S+)\s\)\s;}{
140			$DEBUG ? qq{
141	wakaba	1.5	#print STDERR "$1, ";
142	wakaba	1.4	\$Whatpm::HTML::Debug::cp_pass->($1) if \$Whatpm::HTML::Debug::cp_pass;
143			BEGIN {
144			\$Whatpm::HTML::Debug::cp->{$1} = 1;
145			}
146			} : ''
147			}ge;
148	wakaba	1.1	print;
149			}