| 1 |
wakaba |
1.1 |
package WebHACC::Result; |
| 2 |
|
|
use strict; |
| 3 |
|
|
|
| 4 |
|
|
sub new ($) { |
| 5 |
|
|
return bless {}, shift; |
| 6 |
|
|
} # new |
| 7 |
|
|
|
| 8 |
|
|
|
| 9 |
|
|
sub get_error_label ($$) { |
| 10 |
|
|
my $self = shift; |
| 11 |
|
|
my ($input, $err) = @_; |
| 12 |
|
|
|
| 13 |
|
|
my $r = ''; |
| 14 |
|
|
|
| 15 |
|
|
my $line; |
| 16 |
|
|
my $column; |
| 17 |
|
|
|
| 18 |
|
|
if (defined $err->{node}) { |
| 19 |
|
|
$line = $err->{node}->get_user_data ('manakai_source_line'); |
| 20 |
|
|
if (defined $line) { |
| 21 |
|
|
$column = $err->{node}->get_user_data ('manakai_source_column'); |
| 22 |
|
|
} else { |
| 23 |
|
|
if ($err->{node}->node_type == $err->{node}->ATTRIBUTE_NODE) { |
| 24 |
|
|
my $owner = $err->{node}->owner_element; |
| 25 |
|
|
$line = $owner->get_user_data ('manakai_source_line'); |
| 26 |
|
|
$column = $owner->get_user_data ('manakai_source_column'); |
| 27 |
|
|
} else { |
| 28 |
|
|
my $parent = $err->{node}->parent_node; |
| 29 |
|
|
if ($parent) { |
| 30 |
|
|
$line = $parent->get_user_data ('manakai_source_line'); |
| 31 |
|
|
$column = $parent->get_user_data ('manakai_source_column'); |
| 32 |
|
|
} |
| 33 |
|
|
} |
| 34 |
|
|
} |
| 35 |
|
|
} |
| 36 |
|
|
unless (defined $line) { |
| 37 |
|
|
if (defined $err->{token} and defined $err->{token}->{line}) { |
| 38 |
|
|
$line = $err->{token}->{line}; |
| 39 |
|
|
$column = $err->{token}->{column}; |
| 40 |
|
|
} elsif (defined $err->{line}) { |
| 41 |
|
|
$line = $err->{line}; |
| 42 |
|
|
$column = $err->{column}; |
| 43 |
|
|
} |
| 44 |
|
|
} |
| 45 |
|
|
|
| 46 |
|
|
if (defined $line) { |
| 47 |
|
|
if (defined $column and $column > 0) { |
| 48 |
|
|
$r = qq[<a href="#$input->{id_prefix}line-$line">Line $line</a> column $column]; |
| 49 |
|
|
} else { |
| 50 |
|
|
$line = $line - 1 || 1; |
| 51 |
|
|
$r = qq[<a href="#$input->{id_prefix}line-$line">Line $line</a>]; |
| 52 |
|
|
} |
| 53 |
|
|
} |
| 54 |
|
|
|
| 55 |
|
|
if (defined $err->{node}) { |
| 56 |
|
|
$r .= ' ' if length $r; |
| 57 |
|
|
$r .= $self->get_node_link ($input, $err->{node}); |
| 58 |
|
|
} |
| 59 |
|
|
|
| 60 |
|
|
if (defined $err->{index}) { |
| 61 |
|
|
if (length $r) { |
| 62 |
|
|
$r .= ', Index ' . (0+$err->{index}); |
| 63 |
|
|
} else { |
| 64 |
|
|
$r .= "<a href='#$input->{id_prefix}index-@{[0+$err->{index}]}'>Index " |
| 65 |
|
|
. (0+$err->{index}) . '</a>'; |
| 66 |
|
|
} |
| 67 |
|
|
} |
| 68 |
|
|
|
| 69 |
|
|
if (defined $err->{value}) { |
| 70 |
|
|
$r .= ' ' if length $r; ## BUG: v must be escaped |
| 71 |
|
|
$r .= '<q><code>' . ($err->{value}) . '</code></q>'; |
| 72 |
|
|
} |
| 73 |
|
|
|
| 74 |
|
|
return $r; |
| 75 |
|
|
} # get_error_label |
| 76 |
|
|
|
| 77 |
|
|
sub get_error_level_label ($) { |
| 78 |
|
|
my $self = shift; |
| 79 |
|
|
my $err = shift; |
| 80 |
|
|
|
| 81 |
|
|
my $r = ''; |
| 82 |
|
|
|
| 83 |
|
|
if (not defined $err->{level} or $err->{level} eq 'm') { |
| 84 |
|
|
$r = qq[<strong><a href="../error-description#level-m"><em class=rfc2119>MUST</em>-level |
| 85 |
|
|
error</a></strong>: ]; |
| 86 |
|
|
} elsif ($err->{level} eq 's') { |
| 87 |
|
|
$r = qq[<strong><a href="../error-description#level-s"><em class=rfc2119>SHOULD</em>-level |
| 88 |
|
|
error</a></strong>: ]; |
| 89 |
|
|
} elsif ($err->{level} eq 'w') { |
| 90 |
|
|
$r = qq[<strong><a href="../error-description#level-w">Warning</a></strong>: |
| 91 |
|
|
]; |
| 92 |
|
|
} elsif ($err->{level} eq 'u' or $err->{level} eq 'unsupported') { |
| 93 |
|
|
$r = qq[<strong><a href="../error-description#level-u">Not |
| 94 |
|
|
supported</a></strong>: ]; |
| 95 |
|
|
} elsif ($err->{level} eq 'i') { |
| 96 |
|
|
$r = qq[<strong><a href="../error-description#level-i">Information</a></strong>: ]; |
| 97 |
|
|
} else { |
| 98 |
|
|
my $elevel = htescape ($err->{level}); |
| 99 |
|
|
$r = qq[<strong><a href="../error-description#level-$elevel">$elevel</a></strong>: |
| 100 |
|
|
]; |
| 101 |
|
|
} |
| 102 |
|
|
|
| 103 |
|
|
return $r; |
| 104 |
|
|
} # get_error_level_label |
| 105 |
|
|
|
| 106 |
|
|
sub get_node_path ($) { |
| 107 |
|
|
my $self = shift; |
| 108 |
|
|
my $node = shift; |
| 109 |
|
|
my @r; |
| 110 |
|
|
while (defined $node) { |
| 111 |
|
|
my $rs; |
| 112 |
|
|
if ($node->node_type == 1) { |
| 113 |
|
|
$rs = $node->node_name; |
| 114 |
|
|
$node = $node->parent_node; |
| 115 |
|
|
} elsif ($node->node_type == 2) { |
| 116 |
|
|
$rs = '@' . $node->node_name; |
| 117 |
|
|
$node = $node->owner_element; |
| 118 |
|
|
} elsif ($node->node_type == 3) { |
| 119 |
|
|
$rs = '"' . $node->data . '"'; |
| 120 |
|
|
$node = $node->parent_node; |
| 121 |
|
|
} elsif ($node->node_type == 9) { |
| 122 |
|
|
@r = ('') unless @r; |
| 123 |
|
|
$rs = ''; |
| 124 |
|
|
$node = $node->parent_node; |
| 125 |
|
|
} else { |
| 126 |
|
|
$rs = '#' . $node->node_type; |
| 127 |
|
|
$node = $node->parent_node; |
| 128 |
|
|
} |
| 129 |
|
|
unshift @r, $rs; |
| 130 |
|
|
} |
| 131 |
|
|
return join '/', @r; |
| 132 |
|
|
} # get_node_path |
| 133 |
|
|
|
| 134 |
|
|
use Scalar::Util qw/refaddr/; |
| 135 |
|
|
|
| 136 |
|
|
sub get_node_link ($$) { |
| 137 |
|
|
my $self = shift; |
| 138 |
|
|
return qq[<a href="#$_[0]->{id_prefix}node-@{[refaddr $_[1]]}">] . |
| 139 |
|
|
($self->get_node_path ($_[1])) . qq[</a>]; |
| 140 |
|
|
## BUG: ^ must be escaped |
| 141 |
|
|
} # get_node_link |
| 142 |
|
|
|
| 143 |
|
|
1; |
Parent Directory
| 
Revision Log