line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyrights 2007-2017 by [Mark Overmeer]. |
2
|
|
|
|
|
|
|
# For other contributors see ChangeLog. |
3
|
|
|
|
|
|
|
# See the manual pages for details on the licensing terms. |
4
|
|
|
|
|
|
|
# Pod stripped from pm file by OODoc 2.02. |
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
1482
|
use warnings; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
76
|
|
7
|
2
|
|
|
2
|
|
14
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
77
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
package Log::Report::Extract::Template; |
10
|
2
|
|
|
2
|
|
15
|
use vars '$VERSION'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
118
|
|
11
|
|
|
|
|
|
|
$VERSION = '1.08'; |
12
|
|
|
|
|
|
|
|
13
|
2
|
|
|
2
|
|
15
|
use base 'Log::Report::Extract'; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
587
|
|
14
|
|
|
|
|
|
|
|
15
|
2
|
|
|
2
|
|
13
|
use Log::Report 'log-report-lexicon'; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
11
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub init($) |
19
|
1
|
|
|
1
|
0
|
5
|
{ my ($self, $args) = @_; |
20
|
1
|
|
|
|
|
11
|
$self->SUPER::init($args); |
21
|
|
|
|
|
|
|
$self->{LRET_domain} = $args->{domain} |
22
|
1
|
50
|
|
|
|
8
|
or error "template extract requires explicit domain"; |
23
|
|
|
|
|
|
|
|
24
|
1
|
|
|
|
|
5
|
$self->{LRET_pattern} = $args->{pattern}; |
25
|
1
|
|
|
|
|
5
|
$self; |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#---------- |
29
|
|
|
|
|
|
|
|
30
|
2
|
|
|
2
|
1
|
18
|
sub domain() {shift->{LRET_domain}} |
31
|
1
|
|
|
1
|
1
|
11
|
sub pattern() {shift->{LRET_pattern}} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
#---------- |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub process($@) |
36
|
1
|
|
|
1
|
1
|
1583
|
{ my ($self, $fn, %opts) = @_; |
37
|
|
|
|
|
|
|
|
38
|
1
|
|
50
|
|
|
11
|
my $charset = $opts{charset} || 'utf-8'; |
39
|
1
|
|
|
|
|
9
|
info __x"processing file {fn} in {charset}", fn=> $fn, charset => $charset; |
40
|
|
|
|
|
|
|
|
41
|
1
|
50
|
33
|
|
|
144
|
my $pattern = $opts{pattern} || $self->pattern |
42
|
|
|
|
|
|
|
or error __"need pattern to scan for, either via new() or process()"; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# Slurp the whole file |
45
|
1
|
|
|
|
|
5
|
local *IN; |
46
|
1
|
50
|
|
1
|
|
47
|
open IN, "<:encoding($charset)", $fn |
|
1
|
|
|
|
|
13
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
8
|
|
47
|
|
|
|
|
|
|
or fault __x"cannot read template from {fn}", fn => $fn; |
48
|
|
|
|
|
|
|
|
49
|
1
|
|
|
|
|
1603
|
undef $/; |
50
|
1
|
|
|
|
|
32
|
my $text = ; |
51
|
1
|
|
|
|
|
113
|
close IN; |
52
|
|
|
|
|
|
|
|
53
|
1
|
|
|
|
|
8
|
my $domain = $self->domain; |
54
|
1
|
|
|
|
|
42
|
$self->_reset($domain, $fn); |
55
|
|
|
|
|
|
|
|
56
|
1
|
50
|
|
|
|
13
|
if(ref $pattern eq 'CODE') |
|
|
50
|
|
|
|
|
|
57
|
0
|
|
|
|
|
0
|
{ return $pattern->($fn, \$text); |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
elsif($pattern =~ m/^TT([12])-(\w+)$/) |
60
|
1
|
|
|
|
|
8
|
{ return $self->scanTemplateToolkit($1, $2, $fn, \$text); |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
else |
63
|
0
|
|
|
|
|
0
|
{ error __x"unknown pattern {pattern}", pattern => $pattern; |
64
|
|
|
|
|
|
|
} |
65
|
0
|
|
|
|
|
0
|
(); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub _no_escapes_in($$$$) |
69
|
12
|
|
|
12
|
|
40
|
{ my ($msgid, $plural, $fn, $linenr) = @_; |
70
|
12
|
100
|
33
|
|
|
101
|
return if $msgid !~ /\&\w+\;/ |
|
|
50
|
|
|
|
|
|
71
|
|
|
|
|
|
|
&& (defined $plural ? $plural !~ /\&\w+\;/ : 1); |
72
|
0
|
0
|
|
|
|
0
|
$msgid .= "|$plural" if defined $plural; |
73
|
|
|
|
|
|
|
|
74
|
0
|
|
|
|
|
0
|
warning __x"msgid '{msgid}' contains html escapes, don't do that. File {fn} line {linenr}" |
75
|
|
|
|
|
|
|
, msgid => $msgid, fn => $fn, linenr => $linenr; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub scanTemplateToolkit($$$$) |
79
|
1
|
|
|
1
|
0
|
8
|
{ my ($self, $version, $function, $fn, $textref) = @_; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# Split the whole file on the pattern in four fragments per match: |
82
|
|
|
|
|
|
|
# (text, leading, needed trailing, text, leading, ...) |
83
|
|
|
|
|
|
|
# f.i. ('', '[% loc("', 'some-msgid', '", params) %]', ' more text') |
84
|
1
|
50
|
|
|
|
60
|
my @frags = $version==1 |
85
|
|
|
|
|
|
|
? split(/[\[%]%(.*?)%[%\]]/s, $$textref) |
86
|
|
|
|
|
|
|
: split(/\[%(.*?)%\]/s, $$textref); |
87
|
|
|
|
|
|
|
|
88
|
1
|
|
|
|
|
14
|
my $domain = $self->domain; |
89
|
1
|
|
|
|
|
4
|
my $linenr = 1; |
90
|
1
|
|
|
|
|
3
|
my $msgs_found = 0; |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# pre-compile the regexes, for performance |
93
|
1
|
|
|
|
|
28
|
my $pipe_func_block = qr/^\s*\|\s*$function\b/; |
94
|
1
|
|
|
|
|
39
|
my $msgid_pipe_func = qr/^\s*(["'])([^\r\n]+?)\1\s*\|\s*$function\b/; |
95
|
1
|
|
|
|
|
38
|
my $func_msgid_multi = qr/(\b$function\s*\(\s*)(["'])([^\r\n]+?)\2/s; |
96
|
|
|
|
|
|
|
|
97
|
1
|
|
|
|
|
8
|
while(@frags > 2) |
98
|
12
|
|
|
|
|
46
|
{ my ($skip_text, $take) = (shift @frags, shift @frags); |
99
|
12
|
|
|
|
|
62
|
$linenr += $skip_text =~ tr/\n//; |
100
|
12
|
100
|
|
|
|
124
|
if($take =~ $pipe_func_block) |
101
|
|
|
|
|
|
|
{ # [% | loc(...) %] $msgid [%END%] |
102
|
1
|
50
|
33
|
|
|
25
|
if(@frags < 2 || $frags[1] !~ /^\s*END\s*$/) |
103
|
0
|
|
|
|
|
0
|
{ error __x"template syntax error, no END in {fn} line {line}" |
104
|
|
|
|
|
|
|
, fn => $fn, line => $linenr; |
105
|
|
|
|
|
|
|
} |
106
|
1
|
|
|
|
|
6
|
my $msgid = $frags[0]; # next content |
107
|
1
|
50
|
|
|
|
8
|
my $plural = $msgid =~ s/\|(.*)// ? $1 : undef; |
108
|
1
|
|
|
|
|
7
|
_no_escapes_in $msgid, $plural, $fn, $linenr; |
109
|
|
|
|
|
|
|
|
110
|
1
|
|
|
|
|
8
|
$self->store($domain, $fn, $linenr, $msgid, $plural); |
111
|
1
|
|
|
|
|
4
|
$msgs_found++; |
112
|
|
|
|
|
|
|
|
113
|
1
|
|
|
|
|
5
|
$linenr += $take =~ tr/\n//; |
114
|
1
|
|
|
|
|
5
|
next; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
11
|
100
|
|
|
|
79
|
if($take =~ $msgid_pipe_func) |
118
|
|
|
|
|
|
|
{ # [% $msgid | loc(...) %] |
119
|
1
|
|
|
|
|
6
|
my $msgid = $2; |
120
|
1
|
50
|
|
|
|
9
|
my $plural = $msgid =~ s/\|(.*)// ? $1 : undef; |
121
|
1
|
|
|
|
|
6
|
_no_escapes_in $msgid, $plural, $fn, $linenr; |
122
|
|
|
|
|
|
|
|
123
|
1
|
|
|
|
|
8
|
$self->store($domain, $fn, $linenr, $msgid, $plural); |
124
|
1
|
|
|
|
|
4
|
$msgs_found++; |
125
|
|
|
|
|
|
|
|
126
|
1
|
|
|
|
|
5
|
$linenr += $take =~ tr/\n//; |
127
|
1
|
|
|
|
|
6
|
next; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
# loc($msgid, ...) form, can appear more than once |
131
|
10
|
|
|
|
|
138
|
my @markup = split $func_msgid_multi, $take; |
132
|
10
|
|
|
|
|
50
|
while(@markup > 4) |
133
|
|
|
|
|
|
|
{ # quads with text, call, quote, msgid |
134
|
10
|
|
|
|
|
35
|
$linenr += ($markup[0] =~ tr/\n//) |
135
|
|
|
|
|
|
|
+ ($markup[1] =~ tr/\n//); |
136
|
10
|
|
|
|
|
28
|
my $msgid = $markup[3]; |
137
|
10
|
100
|
|
|
|
49
|
my $plural = $msgid =~ s/\|(.*)// ? $1 : undef; |
138
|
10
|
|
|
|
|
42
|
_no_escapes_in $msgid, $plural, $fn, $linenr; |
139
|
|
|
|
|
|
|
|
140
|
10
|
|
|
|
|
63
|
$self->store($domain, $fn, $linenr, $msgid, $plural); |
141
|
10
|
|
|
|
|
27
|
$msgs_found++; |
142
|
10
|
|
|
|
|
53
|
splice @markup, 0, 4; |
143
|
|
|
|
|
|
|
} |
144
|
10
|
|
|
|
|
55
|
$linenr += $markup[-1] =~ tr/\n//; # rest of container |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
# $linenr += $frags[-1] =~ tr/\n//; # final page fragment not needed |
147
|
|
|
|
|
|
|
|
148
|
1
|
|
|
|
|
15
|
$msgs_found; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
#---------------------------------------------------- |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
1; |