File Coverage

blib/lib/YAML/PP/Highlight.pm
Criterion Covered Total %
statement 78 92 84.7
branch 29 32 90.6
condition 4 8 50.0
subroutine 9 10 90.0
pod 1 4 25.0
total 121 146 82.8


line stmt bran cond sub pod time code
1 1     1   68402 use strict;
  1         10  
  1         28  
2 1     1   5 use warnings;
  1         2  
  1         72  
3             package YAML::PP::Highlight;
4              
5             our $VERSION = '0.036_001'; # TRIAL VERSION
6              
7             our @EXPORT_OK = qw/ Dump /;
8              
9 1     1   6 use base 'Exporter';
  1         2  
  1         145  
10 1     1   533 use YAML::PP;
  1         4  
  1         55  
11 1     1   6 use YAML::PP::Parser;
  1         2  
  1         21  
12 1     1   562 use Encode;
  1         9492  
  1         1203  
13              
14             sub Dump {
15 1     1 1 10394 my (@docs) = @_;
16             # Dumping objects is safe, so we enable the Perl schema here
17 1         588 require YAML::PP::Schema::Perl;
18 1         14 my $yp = YAML::PP->new( schema => [qw/ + Perl /] );
19 1         6 my $yaml = $yp->dump_string(@docs);
20              
21 1         13 my ($error, $tokens) = YAML::PP::Parser->yaml_to_tokens(string => $yaml);
22 1         11 my $highlighted = YAML::PP::Highlight->ansicolored($tokens);
23 1         64 encode_utf8 $highlighted;
24             }
25              
26              
27             my %ansicolors = (
28             ANCHOR => [qw/ green /],
29             ALIAS => [qw/ bold green /],
30             TAG => [qw/ bold blue /],
31             INDENT => [qw/ white on_grey3 /],
32             COMMENT => [qw/ grey12 /],
33             COLON => [qw/ bold magenta /],
34             DASH => [qw/ bold magenta /],
35             QUESTION => [qw/ bold magenta /],
36             YAML_DIRECTIVE => [qw/ cyan /],
37             TAG_DIRECTIVE => [qw/ bold cyan /],
38             SINGLEQUOTE => [qw/ bold green /],
39             SINGLEQUOTED => [qw/ green /],
40             SINGLEQUOTED_LINE => [qw/ green /],
41             DOUBLEQUOTE => [qw/ bold green /],
42             DOUBLEQUOTED => [qw/ green /],
43             DOUBLEQUOTED_LINE => [qw/ green /],
44             LITERAL => [qw/ bold yellow /],
45             FOLDED => [qw/ bold yellow /],
46             DOC_START => [qw/ bold /],
47             DOC_END => [qw/ bold /],
48             BLOCK_SCALAR_CONTENT => [qw/ yellow /],
49             TAB => [qw/ on_blue /],
50             ERROR => [qw/ bold red /],
51             EOL => [qw/ grey12 /],
52             TRAILING_SPACE => [qw/ on_grey6 /],
53             FLOWSEQ_START => [qw/ bold magenta /],
54             FLOWSEQ_END => [qw/ bold magenta /],
55             FLOWMAP_START => [qw/ bold magenta /],
56             FLOWMAP_END => [qw/ bold magenta /],
57             FLOW_COMMA => [qw/ bold magenta /],
58             PLAINKEY => [qw/ bright_blue /],
59             );
60              
61             sub ansicolored {
62 3     3 0 15 my ($class, $tokens, %args) = @_;
63 3         6 my $expand_tabs = $args{expand_tabs};
64 3 100       10 $expand_tabs = 1 unless defined $expand_tabs;
65 3         16 require Term::ANSIColor;
66              
67 3         6 local $Term::ANSIColor::EACHLINE = "\n";
68 3         6 my $ansi = '';
69 3         4 my $highlighted = '';
70              
71 3         9 my @list = $class->transform($tokens);
72              
73              
74 3         24 for my $token (@list) {
75 21         33 my $name = $token->{name};
76 21         29 my $str = $token->{value};
77              
78 21         36 my $color = $ansicolors{ $name };
79 21 100       36 if ($color) {
80 15         35 $str = Term::ANSIColor::colored($color, $str);
81             }
82 21         728 $highlighted .= $str;
83             }
84              
85 3 100       11 if ($expand_tabs) {
86             # Tabs can't be displayed with ansicolors
87 2         9 $highlighted =~ s/\t/' ' x 8/eg;
  1         4  
88             }
89 3         7 $ansi .= $highlighted;
90 3         26 return $ansi;
91             }
92              
93             my %htmlcolors = (
94             ANCHOR => 'anchor',
95             ALIAS => 'alias',
96             SINGLEQUOTE => 'singlequote',
97             DOUBLEQUOTE => 'doublequote',
98             SINGLEQUOTED => 'singlequoted',
99             DOUBLEQUOTED => 'doublequoted',
100             SINGLEQUOTED_LINE => 'singlequoted',
101             DOUBLEQUOTED_LINE => 'doublequoted',
102             INDENT => 'indent',
103             DASH => 'dash',
104             COLON => 'colon',
105             QUESTION => 'question',
106             YAML_DIRECTIVE => 'yaml_directive',
107             TAG_DIRECTIVE => 'tag_directive',
108             TAG => 'tag',
109             COMMENT => 'comment',
110             LITERAL => 'literal',
111             FOLDED => 'folded',
112             DOC_START => 'doc_start',
113             DOC_END => 'doc_end',
114             BLOCK_SCALAR_CONTENT => 'block_scalar_content',
115             TAB => 'tab',
116             ERROR => 'error',
117             EOL => 'eol',
118             TRAILING_SPACE => 'trailing_space',
119             FLOWSEQ_START => 'flowseq_start',
120             FLOWSEQ_END => 'flowseq_end',
121             FLOWMAP_START => 'flowmap_start',
122             FLOWMAP_END => 'flowmap_end',
123             FLOW_COMMA => 'flow_comma',
124             PLAINKEY => 'plainkey',
125             NOEOL => 'noeol',
126             );
127             sub htmlcolored {
128 0     0 0 0 require HTML::Entities;
129 0         0 my ($class, $tokens) = @_;
130 0         0 my $html = '';
131 0         0 my @list = $class->transform($tokens);
132 0         0 for my $token (@list) {
133 0         0 my $name = $token->{name};
134 0         0 my $str = $token->{value};
135 0   0     0 my $colorclass = $htmlcolors{ $name } || 'default';
136 0         0 $str = HTML::Entities::encode_entities($str);
137 0         0 $html .= qq{$str};
138             }
139 0         0 return $html;
140             }
141              
142             sub transform {
143 4     4 0 20 my ($class, $tokens) = @_;
144 4         6 my @list;
145 4         11 for my $token (@$tokens) {
146 27         41 my @values;
147 27         41 my $value = $token->{value};
148 27         38 my $subtokens = $token->{subtokens};
149 27 100       45 if ($subtokens) {
150 2         5 @values = @$subtokens;
151             }
152             else {
153 25         39 @values = $token;
154             }
155 27         36 for my $token (@values) {
156 32 100       63 my $value = defined $token->{orig} ? $token->{orig} : $token->{value};
157 32 50 66     78 if ($token->{name} eq 'EOL' and not length $value) {
158 0         0 push @list, { name => 'NOEOL', value => '' };
159 0         0 next;
160             }
161             push @list, map {
162 32         77 $_ =~ tr/\t/\t/
163             ? { name => 'TAB', value => $_ }
164 36 100       145 : { name => $token->{name}, value => $_ }
165             } split m/(\t+)/, $value;
166             }
167             }
168 4         13 for my $i (0 .. $#list) {
169 36         52 my $token = $list[ $i ];
170 36         56 my $name = $token->{name};
171 36         56 my $str = $token->{value};
172 36         43 my $trailing_space = 0;
173 36 100       86 if ($token->{name} eq 'EOL') {
    50          
174 9 50       26 if ($str =~ m/ +([\r\n]|\z)/) {
175 0         0 $token->{name} = "TRAILING_SPACE";
176             }
177             }
178             elsif ($i < $#list) {
179 27 100       47 if ($name eq 'PLAIN') {
180 8         17 for my $n ($i+1 .. $#list) {
181 25         33 my $next = $list[ $n ];
182 25 100       47 last if $next->{name} eq 'EOL';
183 17 100       52 next if $next->{name} =~ m/^(WS|SPACE)$/;
184 12 100       24 if ($next->{name} eq 'COLON') {
185 5         12 $token->{name} = 'PLAINKEY';
186             }
187             }
188             }
189 27         39 my $next = $list[ $i + 1];
190 27 100       53 if ($next->{name} eq 'EOL') {
191 9 100 66     45 if ($str =~ m/ \z/ and $name =~ m/^(BLOCK_SCALAR_CONTENT|WS|INDENT)$/) {
192 1         3 $token->{name} = "TRAILING_SPACE";
193             }
194             }
195             }
196             }
197 4         14 return @list;
198             }
199              
200             1;
201              
202             __END__