Parent Directory
| 
Revision Log
++ whatpm/Whatpm/ChangeLog 17 Aug 2008 05:06:46 -0000 2008-08-17 Wakaba <wakaba@suika.fam.cx> * H2H.pm (_shift_token): Support for unquoted HTML attribute values. ++ whatpm/Whatpm/ContentChecker/ChangeLog 17 Aug 2008 05:08:51 -0000 2008-08-17 Wakaba <wakaba@suika.fam.cx> * HTML.pm (%XHTML2CommonAttrStatus): HTML5 status was missing.
| 1 | wakaba | 1.1 | package Whatpm::H2H; |
| 2 | use strict; | ||
| 3 | |||
| 4 | sub H2H_NS () { q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Markup/H2H/> } | ||
| 5 | sub HTML_NS () { q<http://www.w3.org/1999/xhtml> } | ||
| 6 | sub HTML3_NS () { q<urn:x-suika-fam-cx:markup:ietf:html:3:draft:00:> } | ||
| 7 | sub SW09_NS () { q<urn:x-suika-fam-cx:markup:suikawiki:0:9:> } | ||
| 8 | sub XHTML2_NS () { q<http://www.w3.org/2002/06/xhtml2/> } | ||
| 9 | |||
| 10 | sub parse_string ($$$) { | ||
| 11 | my $self = bless { | ||
| 12 | token => [], | ||
| 13 | location => {}, | ||
| 14 | doc => $_[2], | ||
| 15 | }, $_[0]; | ||
| 16 | |||
| 17 | my $s = ''.$_[1]; | ||
| 18 | $s =~ s/\x0D\x0A/\x0A/g; | ||
| 19 | $s =~ tr/\x0D/\x0A/; | ||
| 20 | $self->{line} = [split /\x0A/, $s]; | ||
| 21 | |||
| 22 | local $Error::Depth = $Error::Depth + 1; | ||
| 23 | $self->{doc}->strict_error_checking (0); | ||
| 24 | my $doc_el = $self->{doc}->create_element_ns (HTML_NS, 'html'); | ||
| 25 | $doc_el->set_attribute_ns (q<http://www.w3.org/2000/xmlns/>, 'xmlns', HTML_NS); | ||
| 26 | $self->{doc}->append_child ($doc_el); | ||
| 27 | |||
| 28 | $self->_construct_tree; | ||
| 29 | |||
| 30 | return $self->{doc}; | ||
| 31 | } # parse_string | ||
| 32 | |||
| 33 | sub _shift_token ($) { | ||
| 34 | my $self = $_[0]; | ||
| 35 | |||
| 36 | if (@{$self->{token}}) { | ||
| 37 | return shift @{$self->{token}}; | ||
| 38 | } | ||
| 39 | |||
| 40 | my $attrvalue = sub { | ||
| 41 | my $v = shift; | ||
| 42 | $v =~ s/"/"/g; | ||
| 43 | $v =~ s/</</g; | ||
| 44 | $v =~ s/>/>/g; | ||
| 45 | $v =~ s/®/\x{00AE}/g; | ||
| 46 | $v =~ s/♥/\x{2661}/g; | ||
| 47 | $v =~ s/&/&/g; | ||
| 48 | return $v; | ||
| 49 | }; | ||
| 50 | |||
| 51 | my $uriv = sub { | ||
| 52 | my $v = $attrvalue->(shift); | ||
| 53 | $v =~ s/^\{/(/; | ||
| 54 | $v =~ s/\}$/)/; | ||
| 55 | $v =~ s/^\#([0-9si]+)$/($1)/; | ||
| 56 | $v =~ s/^\(([0-9]{4})([0-9]{2})([0-9]{2})([^)]*)\)$/($1, $2, $3$4)/; | ||
| 57 | $v =~ s/[si]/, /g if $v =~ /^\(/ and $v =~ /\)$/; | ||
| 58 | return $v; | ||
| 59 | }; | ||
| 60 | |||
| 61 | my $r = {type => '#EOF'}; | ||
| 62 | L: while (defined (my $line = shift @{$self->{line}})) { | ||
| 63 | if ($line =~ s/^([A-Z]+|T[0-9])(\*?\+?\*?)(?:\s+|$)//) { | ||
| 64 | my $command = $1; | ||
| 65 | my $flag = $2; | ||
| 66 | $r = {type => 'start', value => $command}; | ||
| 67 | |||
| 68 | my $uri; | ||
| 69 | if ($flag =~ /\*/ and $line =~ s/^([^{\s]\S*)\s*//) { | ||
| 70 | $uri = $1; | ||
| 71 | } | ||
| 72 | |||
| 73 | my $attr = ''; | ||
| 74 | if ($line =~ s/^\{(\s*(?:[A-Za-z][^{}]*)?)\}\s*//) { | ||
| 75 | $attr = $1; | ||
| 76 | } | ||
| 77 | |||
| 78 | if (not defined $uri and | ||
| 79 | $flag =~ /\*/ and $line =~ s/^([^{\s]\S*)\s*//) { | ||
| 80 | $uri = $1; | ||
| 81 | } | ||
| 82 | |||
| 83 | my @token; | ||
| 84 | my $info = { | ||
| 85 | # val# val#(*) | ||
| 86 | ABBR => [2, 2], | ||
| 87 | ACRONYM => [2, 2], | ||
| 88 | CITE => [2, 1], | ||
| 89 | LDIARY => [4, 4], | ||
| 90 | LIMG => [4, 4], | ||
| 91 | LINK => [2, 1], | ||