line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/bin/env perl |
2
|
|
|
|
|
|
|
# ABSTRACT: tool to convert between various formats and encodings |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# muter - a data transformation tool |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# Copyright © 2016â2017 brian m. carlson |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# Permission is hereby granted, free of charge, to any person obtaining a copy |
9
|
|
|
|
|
|
|
# of this software and associated documentation files (the "Software"), to deal |
10
|
|
|
|
|
|
|
# in the Software without restriction, including without limitation the rights |
11
|
|
|
|
|
|
|
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell |
12
|
|
|
|
|
|
|
# copies of the Software, and to permit persons to whom the Software is |
13
|
|
|
|
|
|
|
# furnished to do so, subject to the following conditions: |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# The above copyright notice and this permission notice shall be included in |
16
|
|
|
|
|
|
|
# all copies or substantial portions of the Software. |
17
|
|
|
|
|
|
|
# |
18
|
|
|
|
|
|
|
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR |
19
|
|
|
|
|
|
|
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, |
20
|
|
|
|
|
|
|
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE |
21
|
|
|
|
|
|
|
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER |
22
|
|
|
|
|
|
|
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, |
23
|
|
|
|
|
|
|
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN |
24
|
|
|
|
|
|
|
# THE SOFTWARE. |
25
|
|
|
|
|
|
|
package App::Muter; |
26
|
|
|
|
|
|
|
$App::Muter::VERSION = '0.002001'; |
27
|
|
|
|
|
|
|
require 5.010001; |
28
|
|
|
|
|
|
|
|
29
|
4
|
|
|
4
|
|
132034
|
use strict; |
|
4
|
|
|
|
|
13
|
|
|
4
|
|
|
|
|
120
|
|
30
|
4
|
|
|
4
|
|
25
|
use warnings; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
126
|
|
31
|
4
|
|
|
4
|
|
25
|
use feature ':5.10'; |
|
4
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
1233
|
|
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
my $experimental; |
34
|
|
|
|
|
|
|
BEGIN { |
35
|
4
|
50
|
|
4
|
|
112
|
$experimental = 1 if exists $warnings::Offsets{'experimental::smartmatch'}; |
36
|
|
|
|
|
|
|
} |
37
|
4
|
|
|
4
|
|
2055
|
no if $experimental, warnings => 'experimental::smartmatch'; |
|
4
|
|
|
|
|
38
|
|
|
4
|
|
|
|
|
19
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
## no critic(ProhibitMultiplePackages) |
41
|
|
|
|
|
|
|
package App::Muter::Main; |
42
|
|
|
|
|
|
|
$App::Muter::Main::VERSION = '0.002001'; |
43
|
4
|
|
|
4
|
|
1697
|
use App::Muter::Backend (); |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
72
|
|
44
|
4
|
|
|
4
|
|
1402
|
use App::Muter::Chain (); |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
70
|
|
45
|
4
|
|
|
4
|
|
25
|
use FindBin (); |
|
4
|
|
|
|
|
16
|
|
|
4
|
|
|
|
|
67
|
|
46
|
4
|
|
|
4
|
|
2429
|
use Getopt::Long (); |
|
4
|
|
|
|
|
39813
|
|
|
4
|
|
|
|
|
132
|
|
47
|
4
|
|
|
4
|
|
1012
|
use IO::Handle (); |
|
4
|
|
|
|
|
7425
|
|
|
4
|
|
|
|
|
70
|
|
48
|
4
|
|
|
4
|
|
1642
|
use IO::File (); |
|
4
|
|
|
|
|
5245
|
|
|
4
|
|
|
|
|
90
|
|
49
|
|
|
|
|
|
|
|
50
|
4
|
|
|
4
|
|
1963
|
use File::stat; |
|
4
|
|
|
|
|
24583
|
|
|
4
|
|
|
|
|
21
|
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub script { |
53
|
0
|
|
|
0
|
|
0
|
my (@args) = @_; |
54
|
|
|
|
|
|
|
|
55
|
0
|
|
|
|
|
0
|
my $chain = ''; |
56
|
0
|
|
|
|
|
0
|
my $help; |
57
|
|
|
|
|
|
|
my $verbose; |
58
|
0
|
|
|
|
|
0
|
my $reverse; |
59
|
0
|
0
|
|
|
|
0
|
Getopt::Long::GetOptionsFromArray( |
60
|
|
|
|
|
|
|
\@args, |
61
|
|
|
|
|
|
|
'chain|c=s' => \$chain, |
62
|
|
|
|
|
|
|
'verbose|v' => \$verbose, |
63
|
|
|
|
|
|
|
'reverse|r!' => \$reverse, |
64
|
|
|
|
|
|
|
'help' => \$help |
65
|
|
|
|
|
|
|
) or |
66
|
|
|
|
|
|
|
return usage(1); |
67
|
|
|
|
|
|
|
|
68
|
0
|
|
|
|
|
0
|
load_backends(); |
69
|
|
|
|
|
|
|
|
70
|
0
|
0
|
|
|
|
0
|
return usage(0, $verbose) if $help; |
71
|
0
|
0
|
|
|
|
0
|
return usage(1) unless $chain; |
72
|
|
|
|
|
|
|
|
73
|
0
|
|
|
|
|
0
|
run_chain($chain, $reverse, load_handles(\@args), \*STDOUT); |
74
|
|
|
|
|
|
|
|
75
|
0
|
|
|
|
|
0
|
return 0; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub _uniq { ## no critic(RequireArgUnpacking) |
79
|
0
|
|
|
0
|
|
0
|
my %seen; |
80
|
0
|
|
|
|
|
0
|
return grep { !$seen{$_}++ } @_; |
|
0
|
|
|
|
|
0
|
|
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub load_backends { |
84
|
0
|
|
|
0
|
|
0
|
App::Muter::Registry->instance->load_backends(); |
85
|
0
|
|
|
|
|
0
|
return; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
sub load_handles { |
89
|
0
|
|
|
0
|
|
0
|
my ($files) = @_; |
90
|
0
|
|
|
|
|
0
|
my @handles = map { IO::File->new($_, 'r') } @$files; |
|
0
|
|
|
|
|
0
|
|
91
|
0
|
0
|
|
|
|
0
|
@handles = (\*STDIN) unless @handles; |
92
|
0
|
|
|
|
|
0
|
return \@handles; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
sub run_chain { |
96
|
15762
|
|
|
15762
|
|
13941780
|
my ($chain, $reverse, $handles, $stdout, $blocksize) = @_; |
97
|
|
|
|
|
|
|
|
98
|
15762
|
|
|
|
|
89956
|
$chain = App::Muter::Chain->new($chain, $reverse); |
99
|
15762
|
|
50
|
|
|
46923
|
$blocksize ||= 512; |
100
|
|
|
|
|
|
|
|
101
|
15762
|
|
|
|
|
39121
|
foreach my $io (@$handles) { |
102
|
15762
|
|
|
|
|
66833
|
$io->binmode(1); |
103
|
15762
|
|
|
|
|
75560
|
while ($io->read(my $buf, $blocksize)) { |
104
|
51942
|
|
|
|
|
1270541
|
$stdout->print($chain->process($buf)); |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
} |
107
|
15762
|
|
|
|
|
465928
|
$stdout->print($chain->final('')); |
108
|
15762
|
|
|
|
|
500207
|
return; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub usage { |
112
|
0
|
|
|
0
|
|
0
|
my ($ret, $verbose) = @_; |
113
|
0
|
0
|
|
|
|
0
|
my $fh = $ret ? \*STDERR : \*STDOUT; |
114
|
0
|
|
|
|
|
0
|
$fh->print(<<'EOM'); |
115
|
|
|
|
|
|
|
muter [-r | --reverse] -c CHAIN | --chain CHAIN [FILES...] |
116
|
|
|
|
|
|
|
muter [--verbose] --help |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
Modify the bytes in the concatentation of FILES (or standard input) by using the |
119
|
|
|
|
|
|
|
specification in CHAIN. |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
CHAIN is a colon-separated list of encoding transform. A transform can be |
122
|
|
|
|
|
|
|
prefixed with - to reverse it (if possible). A transform can be followed by one |
123
|
|
|
|
|
|
|
or more comma-separated parenthesized arguments as well. Instead of |
124
|
|
|
|
|
|
|
parentheses, a single comma may be used. |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
For example, '-hex:hash(sha256):base64' (or '-hex:hash,sha256:base64') decodes a |
127
|
|
|
|
|
|
|
hex-encoded string, hashes it with SHA-256, and converts the result to base64. |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
If --reverse is specified, reverse the order of transforms in order and in sense. |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
The following transforms are available: |
132
|
|
|
|
|
|
|
EOM |
133
|
0
|
|
|
|
|
0
|
my $reg = App::Muter::Registry->instance; |
134
|
0
|
|
|
|
|
0
|
foreach my $name ($reg->backends) { |
135
|
0
|
|
|
|
|
0
|
$fh->print(" $name\n"); |
136
|
0
|
|
|
|
|
0
|
my $meta = $reg->info($name); |
137
|
0
|
0
|
0
|
|
|
0
|
if ($meta->{args} && ref($meta->{args}) eq 'HASH') { |
138
|
0
|
|
|
|
|
0
|
my @keys = sort keys %{$meta->{args}}; |
|
0
|
|
|
|
|
0
|
|
139
|
0
|
0
|
|
|
|
0
|
if ($verbose) { |
140
|
|
|
|
|
|
|
$fh->printf(" %-10s: %s\n", $_, $meta->{args}->{$_}) |
141
|
0
|
|
|
|
|
0
|
for @keys; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
else { |
144
|
0
|
|
|
|
|
0
|
$fh->print(" ", join(', ', sort keys %{$meta->{args}}), |
|
0
|
|
|
|
|
0
|
|
145
|
|
|
|
|
|
|
"\n"); |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
} |
149
|
0
|
|
|
|
|
0
|
return $ret; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
package App::Muter::Interface; |
153
|
|
|
|
|
|
|
$App::Muter::Interface::VERSION = '0.002001'; |
154
|
|
|
|
|
|
|
sub process { |
155
|
1229
|
|
|
1229
|
|
675386
|
my ($chain, $data) = @_; |
156
|
|
|
|
|
|
|
|
157
|
1229
|
|
|
|
|
5235
|
$chain = App::Muter::Chain->new($chain); |
158
|
1229
|
|
|
|
|
4724
|
my $result = $chain->process($data); |
159
|
1229
|
|
|
|
|
6588
|
$result .= $chain->final(''); |
160
|
|
|
|
|
|
|
|
161
|
1229
|
|
|
|
|
13433
|
return $result; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
package App::Muter::Registry; |
165
|
|
|
|
|
|
|
$App::Muter::Registry::VERSION = '0.002001'; |
166
|
4
|
|
|
4
|
|
3243
|
use File::Spec; |
|
4
|
|
|
|
|
11
|
|
|
4
|
|
|
|
|
4060
|
|
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
my $instance; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub instance { |
171
|
17048
|
|
|
17048
|
|
35476
|
my $class = shift; |
172
|
17048
|
|
33
|
|
|
66931
|
$class = ref($class) || $class; |
173
|
17048
|
|
|
|
|
47896
|
my $self = {names => {}}; |
174
|
17048
|
|
100
|
|
|
79545
|
return $instance ||= bless $self, $class; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub register { |
178
|
54
|
|
|
54
|
|
153
|
my ($self, $class) = @_; |
179
|
54
|
|
|
|
|
339
|
my $info = $class->metadata; |
180
|
54
|
|
|
|
|
219
|
$self->{names}{$info->{name}} = {%$info, class => $class}; |
181
|
54
|
|
|
|
|
246
|
return 1; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
sub info { |
185
|
24742
|
|
|
24742
|
|
55573
|
my ($self, $name) = @_; |
186
|
24742
|
|
|
|
|
56544
|
my $info = $self->{names}{$name}; |
187
|
24742
|
50
|
|
|
|
61273
|
die "No such transform '$name'" unless $info; |
188
|
24742
|
|
|
|
|
67426
|
return $info; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
sub backends { |
192
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
193
|
0
|
|
|
|
|
0
|
my @backends = sort keys %{$self->{names}}; |
|
0
|
|
|
|
|
0
|
|
194
|
0
|
|
|
|
|
0
|
return @backends; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub load_backends { |
198
|
3
|
|
|
3
|
|
9
|
my ($self) = @_; |
199
|
36
|
100
|
|
|
|
116
|
my @modules = map { /^([A-Za-z0-9]+)\.pm$/ ? ($1) : () } map { |
200
|
30
|
|
|
|
|
56
|
my $dh; |
201
|
30
|
100
|
|
|
|
784
|
opendir($dh, $_) ? readdir($dh) : () |
202
|
3
|
|
|
|
|
9
|
} map { File::Spec->catfile($_, qw/App Muter Backend/) } @INC; |
|
30
|
|
|
|
|
188
|
|
203
|
|
|
|
|
|
|
eval "require App::Muter::Backend::$_;" ##no critic(ProhibitStringyEval) |
204
|
3
|
|
|
|
|
234
|
for @modules; |
205
|
3
|
|
|
|
|
12
|
return; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
package App::Muter::Backend::Chunked; |
209
|
|
|
|
|
|
|
$App::Muter::Backend::Chunked::VERSION = '0.002001'; |
210
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend/; |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
sub new { |
213
|
11778
|
|
|
11778
|
|
41331
|
my ($class, $args, %opts) = @_; |
214
|
11778
|
|
|
|
|
43434
|
my $self = $class->SUPER::new($args, %opts); |
215
|
11778
|
|
|
|
|
26848
|
$self->{chunk} = ''; |
216
|
11778
|
|
33
|
|
|
32360
|
$self->{enchunksize} = $opts{enchunksize} || $opts{chunksize}; |
217
|
11778
|
|
33
|
|
|
39037
|
$self->{dechunksize} = $opts{dechunksize} || $opts{chunksize}; |
218
|
11778
|
|
|
|
|
29901
|
return $self; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
sub encode { |
222
|
22903
|
|
|
22903
|
|
41010
|
my ($self, $data) = @_; |
223
|
22903
|
|
|
|
|
53766
|
return $self->_with_chunk($data, $self->{enchunksize}, 'encode_chunk'); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
sub decode { |
227
|
24277
|
|
|
24277
|
|
44091
|
my ($self, $data) = @_; |
228
|
24277
|
|
|
|
|
53771
|
return $self->_with_chunk($data, $self->{dechunksize}, 'decode_chunk'); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
sub encode_final { |
232
|
6161
|
|
|
6161
|
|
12051
|
my ($self, $data) = @_; |
233
|
6161
|
|
|
|
|
17287
|
return $self->encode_chunk($self->{chunk} . $data); |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
sub decode_final { |
237
|
5250
|
|
|
5250
|
|
11175
|
my ($self, $data) = @_; |
238
|
5250
|
|
|
|
|
15147
|
return $self->decode_chunk($self->{chunk} . $data); |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
sub _with_chunk { |
242
|
47180
|
|
|
47180
|
|
87759
|
my ($self, $data, $chunksize, $code) = @_; |
243
|
47180
|
|
|
|
|
88279
|
my $chunk = $self->{chunk} . $data; |
244
|
47180
|
|
|
|
|
70541
|
my $len = length($chunk); |
245
|
47180
|
|
|
|
|
74648
|
my $rem = $len % $chunksize; |
246
|
47180
|
100
|
|
|
|
88735
|
if ($rem) { |
247
|
23384
|
|
|
|
|
48992
|
$self->{chunk} = substr($chunk, -$rem); |
248
|
23384
|
|
|
|
|
42091
|
$chunk = substr($chunk, 0, -$rem); |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
else { |
251
|
23796
|
|
|
|
|
39775
|
$self->{chunk} = ''; |
252
|
|
|
|
|
|
|
} |
253
|
47180
|
|
|
|
|
114936
|
return $self->$code($chunk); |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
package App::Muter::Backend::ChunkedDecode; |
257
|
|
|
|
|
|
|
$App::Muter::Backend::ChunkedDecode::VERSION = '0.002001'; |
258
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend/; |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
sub new { |
261
|
9312
|
|
|
9312
|
|
34356
|
my ($class, $args, %opts) = @_; |
262
|
9312
|
|
|
|
|
45614
|
my $self = $class->SUPER::new($args, %opts); |
263
|
9312
|
|
|
|
|
23440
|
$self->{chunk} = ''; |
264
|
9312
|
|
|
|
|
20764
|
$self->{regexp} = $opts{regexp}; |
265
|
9312
|
|
|
|
|
27386
|
return $self; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
sub encode { |
269
|
19943
|
|
|
19943
|
|
41120
|
my ($self, $data) = @_; |
270
|
19943
|
|
|
|
|
44275
|
return $self->encode_chunk($data); |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
sub decode { |
274
|
20044
|
|
|
20044
|
|
38295
|
my ($self, $data) = @_; |
275
|
20044
|
|
|
|
|
42588
|
$data = $self->{chunk} . $data; |
276
|
20044
|
100
|
|
|
|
138789
|
if ($data =~ $self->{regexp}) { |
277
|
5182
|
|
100
|
|
|
25673
|
$data = $1 // ''; |
278
|
5182
|
|
|
|
|
12333
|
$self->{chunk} = $2; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
else { |
281
|
14862
|
|
|
|
|
34643
|
$self->{chunk} = ''; |
282
|
|
|
|
|
|
|
} |
283
|
20044
|
|
|
|
|
49441
|
return $self->decode_chunk($data); |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
sub encode_final { |
287
|
4259
|
|
|
4259
|
|
11624
|
my ($self, $data) = @_; |
288
|
4259
|
|
|
|
|
15924
|
return $self->encode_chunk($self->{chunk} . $data); |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
sub decode_final { |
292
|
4545
|
|
|
4545
|
|
10414
|
my ($self, $data) = @_; |
293
|
4545
|
|
|
|
|
16301
|
return $self->decode_chunk($self->{chunk} . $data); |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
package App::Muter::Backend::Base64; |
297
|
|
|
|
|
|
|
$App::Muter::Backend::Base64::VERSION = '0.002001'; |
298
|
4
|
|
|
4
|
|
1891
|
use MIME::Base64 (); |
|
4
|
|
|
|
|
1915
|
|
|
4
|
|
|
|
|
1824
|
|
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::Chunked/; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
sub new { |
303
|
2763
|
|
|
2763
|
|
7648
|
my ($class, $args, %opts) = @_; |
304
|
2763
|
100
|
|
|
|
6755
|
my $nl = (grep { $_ eq 'mime' } @$args) ? "\n" : ''; |
|
1026
|
|
|
|
|
3765
|
|
305
|
2763
|
100
|
|
|
|
10911
|
my $self = $class->SUPER::new( |
306
|
|
|
|
|
|
|
$args, %opts, |
307
|
|
|
|
|
|
|
enchunksize => $nl ? 57 : 3, |
308
|
|
|
|
|
|
|
dechunksize => 4 |
309
|
|
|
|
|
|
|
); |
310
|
2763
|
|
|
|
|
5655
|
$self->{nl} = $nl; |
311
|
2763
|
100
|
|
|
|
6109
|
if (grep { $_ eq 'yui' } @$args) { |
|
1026
|
|
|
|
|
3186
|
|
312
|
84
|
|
|
107
|
|
264
|
$self->{exfrm} = sub { (my $x = shift) =~ tr{+/=}{._-}; return $x }; |
|
107
|
|
|
|
|
199
|
|
|
107
|
|
|
|
|
436
|
|
313
|
84
|
|
|
85
|
|
186
|
$self->{dxfrm} = sub { (my $x = shift) =~ tr{._-}{+/=}; return $x }; |
|
85
|
|
|
|
|
154
|
|
|
85
|
|
|
|
|
166
|
|
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
else { |
316
|
2679
|
|
|
6431
|
|
9859
|
$self->{exfrm} = sub { return shift }; |
|
6431
|
|
|
|
|
25259
|
|
317
|
2679
|
|
|
10643
|
|
7992
|
$self->{dxfrm} = sub { return shift }; |
|
10643
|
|
|
|
|
19812
|
|
318
|
|
|
|
|
|
|
} |
319
|
2763
|
|
|
|
|
12263
|
return $self; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
sub encode_chunk { |
323
|
6538
|
|
|
6538
|
|
11887
|
my ($self, $data) = @_; |
324
|
6538
|
|
|
|
|
20714
|
return $self->{exfrm}->(MIME::Base64::encode($data, $self->{nl})); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
sub _filter { |
328
|
9644
|
|
|
9644
|
|
16033
|
my ($self, $data) = @_; |
329
|
9644
|
|
|
|
|
15990
|
$data =~ tr{A-Za-z0-9+/=}{}cd; |
330
|
9644
|
|
|
|
|
22755
|
return $data; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub decode { |
334
|
10728
|
|
|
10728
|
|
17903
|
my ($self, $data) = @_; |
335
|
10728
|
|
|
|
|
20514
|
$data = $self->{dxfrm}->($data); |
336
|
10728
|
|
|
|
|
23497
|
return $self->SUPER::decode($self->_filter($data)); |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
sub decode_chunk { |
340
|
10508
|
|
|
10508
|
|
18377
|
my (undef, $data) = @_; |
341
|
10508
|
|
|
|
|
43231
|
return MIME::Base64::decode($data); |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
package App::Muter::Backend::URL64; |
347
|
|
|
|
|
|
|
$App::Muter::Backend::URL64::VERSION = '0.002001'; |
348
|
4
|
|
|
4
|
|
31
|
use MIME::Base64 3.11 (); |
|
4
|
|
|
|
|
87
|
|
|
4
|
|
|
|
|
4131
|
|
349
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::Base64/; |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
sub encode_chunk { |
352
|
1250
|
|
|
1250
|
|
2302
|
my (undef, $data) = @_; |
353
|
1250
|
|
|
|
|
3138
|
return MIME::Base64::encode_base64url($data); |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
sub _filter { |
357
|
1084
|
|
|
1084
|
|
1953
|
my (undef, $data) = @_; |
358
|
1084
|
|
|
|
|
2819
|
return $data; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub decode_chunk { |
362
|
1372
|
|
|
1372
|
|
2571
|
my (undef, $data) = @_; |
363
|
1372
|
|
|
|
|
3225
|
return MIME::Base64::decode_base64url($data); |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
package App::Muter::Backend::Hex; |
369
|
|
|
|
|
|
|
$App::Muter::Backend::Hex::VERSION = '0.002001'; |
370
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::Chunked/; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
sub new { |
373
|
1095
|
|
|
1095
|
|
3053
|
my ($class, $args, %opts) = @_; |
374
|
1095
|
|
|
|
|
3753
|
my $self = $class->SUPER::new( |
375
|
|
|
|
|
|
|
$args, %opts, |
376
|
|
|
|
|
|
|
enchunksize => 1, |
377
|
|
|
|
|
|
|
dechunksize => 2 |
378
|
|
|
|
|
|
|
); |
379
|
1095
|
100
|
100
|
|
|
4554
|
$self->{upper} = 1 if defined $args->[0] && $args->[0] eq 'upper'; |
380
|
1095
|
|
|
|
|
3844
|
return $self; |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
sub metadata { |
384
|
8
|
|
|
8
|
|
14
|
my $self = shift; |
385
|
8
|
|
|
|
|
35
|
my $meta = $self->SUPER::metadata; |
386
|
|
|
|
|
|
|
return { |
387
|
8
|
|
|
|
|
48
|
%$meta, |
388
|
|
|
|
|
|
|
args => { |
389
|
|
|
|
|
|
|
upper => 'Use uppercase letters', |
390
|
|
|
|
|
|
|
lower => 'Use lowercase letters', |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
}; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
sub encode_chunk { |
396
|
6476
|
|
|
6476
|
|
11589
|
my ($self, $data) = @_; |
397
|
6476
|
|
|
|
|
17078
|
my $result = unpack("H*", $data); |
398
|
6476
|
100
|
|
|
|
18058
|
return uc $result if $self->{upper}; |
399
|
5325
|
|
|
|
|
22754
|
return $result; |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
sub decode_chunk { |
403
|
2380
|
|
|
2380
|
|
4622
|
my (undef, $data) = @_; |
404
|
2380
|
|
|
|
|
13178
|
return pack("H*", $data); |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
package App::Muter::Backend::Base16; |
410
|
|
|
|
|
|
|
$App::Muter::Backend::Base16::VERSION = '0.002001'; |
411
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::Hex/; |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
sub new { |
414
|
475
|
|
|
475
|
|
1232
|
my ($class, $args, %opts) = @_; |
415
|
475
|
|
|
|
|
1401
|
my $self = $class->SUPER::new(['upper'], %opts); |
416
|
475
|
|
|
|
|
1803
|
return $self; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
sub metadata { |
420
|
4
|
|
|
4
|
|
11
|
my $self = shift; |
421
|
4
|
|
|
|
|
21
|
my $meta = $self->SUPER::metadata; |
422
|
4
|
|
|
|
|
13
|
delete $meta->{args}; |
423
|
4
|
|
|
|
|
9
|
return $meta; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
package App::Muter::Backend::Base32; |
429
|
|
|
|
|
|
|
$App::Muter::Backend::Base32::VERSION = '0.002001'; |
430
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::Chunked/; |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub new { |
433
|
6672
|
|
|
6672
|
|
17539
|
my ($class, @args) = @_; |
434
|
6672
|
|
|
|
|
19311
|
my $self = $class->SUPER::new(@args, enchunksize => 5, dechunksize => 8); |
435
|
|
|
|
|
|
|
$self->{ftr} = |
436
|
6672
|
|
|
3264
|
|
26735
|
sub { my $val = shift; $val =~ tr/\x00-\x1f/A-Z2-7/; return $val }; |
|
3264
|
|
|
|
|
6683
|
|
|
3264
|
|
|
|
|
7285
|
|
|
3264
|
|
|
|
|
17766
|
|
437
|
|
|
|
|
|
|
$self->{rtr} = |
438
|
6672
|
|
|
3258
|
|
19654
|
sub { my $val = shift; $val =~ tr/A-Z2-7/\x00-\x1f/; return $val }; |
|
3258
|
|
|
|
|
6332
|
|
|
3258
|
|
|
|
|
7296
|
|
|
3258
|
|
|
|
|
14513
|
|
439
|
6672
|
|
|
|
|
14471
|
$self->{func} = 'base32'; |
440
|
|
|
|
|
|
|
$self->{manual} = |
441
|
6672
|
|
|
|
|
22716
|
grep { $_ eq 'manual' } @args || |
442
|
6672
|
|
33
|
|
|
18748
|
!eval { require MIME::Base32; MIME::Base32->VERSION(1.0) }; |
443
|
6672
|
|
|
|
|
18290
|
return $self->_initialize; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
sub _initialize { |
447
|
8174
|
|
|
8174
|
|
16486
|
my ($self) = @_; |
448
|
8174
|
50
|
|
|
|
19994
|
unless ($self->{manual}) { |
449
|
8174
|
|
|
|
|
40761
|
$self->{eref} = MIME::Base32->can("encode_$self->{func}"); |
450
|
8174
|
|
|
|
|
29252
|
$self->{dref} = MIME::Base32->can("decode_$self->{func}"); |
451
|
|
|
|
|
|
|
} |
452
|
8174
|
|
|
|
|
36013
|
return $self; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
sub encode_chunk { |
456
|
10512
|
|
|
10512
|
|
20247
|
my ($self, $data) = @_; |
457
|
10512
|
100
|
|
|
|
39786
|
return '' unless length($data); |
458
|
4687
|
50
|
|
|
|
11769
|
return $self->{eref}->($data) if $self->{eref}; |
459
|
4687
|
|
|
|
|
8551
|
my $len = length($data); |
460
|
4687
|
|
|
|
|
8094
|
my $rem = $len % 5; |
461
|
4687
|
|
|
|
|
10828
|
my $lenmap = [0, 2, 4, 5, 7, 8]; |
462
|
4687
|
|
|
|
|
8975
|
my $lm = $lenmap->[$rem]; |
463
|
4687
|
100
|
|
|
|
21948
|
my @data = (unpack('C*', $data), ($rem ? ((0) x (5 - $rem)) : ())); |
464
|
4687
|
|
|
|
|
9411
|
my $result = ''; |
465
|
4687
|
|
|
|
|
13056
|
my $truncate = int($len / 5) * 8 + $lm; |
466
|
4687
|
|
|
|
|
16539
|
while (my @chunk = splice(@data, 0, 5)) { |
467
|
5035
|
|
|
|
|
16952
|
my @converted = map { $_ & 0x1f } ( |
|
40280
|
|
|
|
|
72152
|
|
468
|
|
|
|
|
|
|
$chunk[0] >> 3, |
469
|
|
|
|
|
|
|
($chunk[0] << 2) | ($chunk[1] >> 6), |
470
|
|
|
|
|
|
|
($chunk[1] >> 1), |
471
|
|
|
|
|
|
|
($chunk[1] << 4) | ($chunk[2] >> 4), |
472
|
|
|
|
|
|
|
($chunk[2] << 1) | ($chunk[3] >> 7), |
473
|
|
|
|
|
|
|
($chunk[3] >> 2), |
474
|
|
|
|
|
|
|
($chunk[3] << 3) | ($chunk[4] >> 5), |
475
|
|
|
|
|
|
|
$chunk[4] |
476
|
|
|
|
|
|
|
); |
477
|
5035
|
|
|
|
|
27083
|
$result .= pack('C*', @converted); |
478
|
|
|
|
|
|
|
} |
479
|
4687
|
|
|
|
|
10564
|
$result = substr($result, 0, $truncate); |
480
|
4687
|
100
|
|
|
|
12630
|
$result .= $lm ? ('=' x (8 - $lm)) : ''; |
481
|
4687
|
|
|
|
|
13923
|
return $self->{ftr}->($result); |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
sub decode_chunk { |
485
|
14047
|
|
|
14047
|
|
27456
|
my ($self, $data) = @_; |
486
|
14047
|
100
|
|
|
|
64295
|
return '' unless length($data); |
487
|
4678
|
50
|
|
|
|
12523
|
return $self->{dref}->($data) if $self->{dref}; |
488
|
4678
|
|
|
|
|
11218
|
my $lenmap = [5, 4, undef, 3, 2, undef, 1]; |
489
|
4678
|
100
|
|
|
|
24917
|
my $trailing = $data =~ /(=+)$/ ? length $1 : 0; |
490
|
4678
|
|
|
|
|
9445
|
my $truncate = $lenmap->[$trailing]; |
491
|
4678
|
|
|
|
|
8288
|
my $result = ''; |
492
|
4678
|
|
|
|
|
11574
|
my @data = unpack('C*', $self->{rtr}->($data)); |
493
|
4
|
|
|
4
|
|
2615
|
use bytes; |
|
4
|
|
|
|
|
51
|
|
|
4
|
|
|
|
|
19
|
|
494
|
|
|
|
|
|
|
|
495
|
4678
|
|
|
|
|
19218
|
while (my @chunk = splice(@data, 0, 8)) { |
496
|
5035
|
|
|
|
|
18735
|
my @converted = ( |
497
|
|
|
|
|
|
|
($chunk[0] << 3) | ($chunk[1] >> 2), |
498
|
|
|
|
|
|
|
($chunk[1] << 6) | ($chunk[2] << 1) | ($chunk[3] >> 4), |
499
|
|
|
|
|
|
|
($chunk[3] << 4) | ($chunk[4] >> 1), |
500
|
|
|
|
|
|
|
($chunk[4] << 7) | ($chunk[5] << 2) | ($chunk[6] >> 3), |
501
|
|
|
|
|
|
|
($chunk[6] << 5) | $chunk[7], |
502
|
|
|
|
|
|
|
); |
503
|
5035
|
|
|
|
|
9743
|
my $chunk = pack('C*', map { $_ & 0xff } @converted); |
|
25175
|
|
|
|
|
48544
|
|
504
|
5035
|
100
|
|
|
|
26753
|
$result .= substr($chunk, 0, (@data ? 5 : $truncate)); |
505
|
|
|
|
|
|
|
} |
506
|
4678
|
|
|
|
|
29496
|
return $result; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
sub metadata { |
510
|
8
|
|
|
8
|
|
13
|
my $self = shift; |
511
|
8
|
|
|
|
|
32
|
my $meta = $self->SUPER::metadata; |
512
|
|
|
|
|
|
|
return { |
513
|
8
|
|
|
|
|
36
|
%$meta, |
514
|
|
|
|
|
|
|
args => { |
515
|
|
|
|
|
|
|
'manual' => 'Disable use of MIME::Base32', |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
}; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
package App::Muter::Backend::Base32Hex; |
523
|
|
|
|
|
|
|
$App::Muter::Backend::Base32Hex::VERSION = '0.002001'; |
524
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::Base32/; |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
sub new { |
527
|
1502
|
|
|
1502
|
|
3554
|
my ($class, @args) = @_; |
528
|
1502
|
|
|
|
|
3665
|
my $self = $class->SUPER::new(@args); |
529
|
|
|
|
|
|
|
$self->{ftr} = |
530
|
1502
|
|
|
1423
|
|
4451
|
sub { my $val = shift; $val =~ tr/\x00-\x1f/0-9A-V/; return $val }; |
|
1423
|
|
|
|
|
2898
|
|
|
1423
|
|
|
|
|
2644
|
|
|
1423
|
|
|
|
|
5777
|
|
531
|
|
|
|
|
|
|
$self->{rtr} = |
532
|
1502
|
|
|
1420
|
|
5359
|
sub { my $val = shift; $val =~ tr/0-9A-V/\x00-\x1f/; return $val }; |
|
1420
|
|
|
|
|
2458
|
|
|
1420
|
|
|
|
|
2659
|
|
|
1420
|
|
|
|
|
4741
|
|
533
|
1502
|
|
|
|
|
3639
|
$self->{func} = 'base32hex'; |
534
|
1502
|
|
|
|
|
3007
|
return $self->_initialize; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
package App::Muter::Backend::URI; |
540
|
|
|
|
|
|
|
$App::Muter::Backend::URI::VERSION = '0.002001'; |
541
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::ChunkedDecode/; |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub new { |
544
|
2522
|
|
|
2522
|
|
7614
|
my ($class, $args, %opts) = @_; |
545
|
2522
|
|
|
|
|
13396
|
my $self = $class->SUPER::new($args, %opts, regexp => qr/^(.*)(%.?)$/); |
546
|
2522
|
|
|
|
|
5684
|
my $lower = grep { $_ eq 'lower' } @$args; |
|
1544
|
|
|
|
|
4639
|
|
547
|
2522
|
|
|
|
|
5004
|
$self->{chunk} = ''; |
548
|
2522
|
100
|
|
|
|
9890
|
$self->{format} = '%%%02' . ($lower ? 'x' : 'X'); |
549
|
2522
|
|
|
|
|
5096
|
$self->{form} = grep { $_ eq 'form' } @$args; |
|
1544
|
|
|
|
|
4243
|
|
550
|
2522
|
|
|
|
|
11426
|
return $self; |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
sub metadata { |
554
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
555
|
4
|
|
|
|
|
24
|
my $meta = $self->SUPER::metadata; |
556
|
|
|
|
|
|
|
return { |
557
|
4
|
|
|
|
|
22
|
%$meta, |
558
|
|
|
|
|
|
|
args => { |
559
|
|
|
|
|
|
|
'upper' => 'Use uppercase letters', |
560
|
|
|
|
|
|
|
'lower' => 'Use lowercase letters', |
561
|
|
|
|
|
|
|
'form' => 'Encode space as +', |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
}; |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
sub encode_chunk { |
567
|
5763
|
|
|
5763
|
|
10980
|
my ($self, $data) = @_; |
568
|
5763
|
|
|
|
|
20838
|
$data =~ s/([^A-Za-z0-9-._~])/sprintf $self->{format}, ord($1)/ge; |
|
7033
|
|
|
|
|
29868
|
|
569
|
5763
|
100
|
|
|
|
16769
|
$data =~ s/%20/+/g if $self->{form}; |
570
|
5763
|
|
|
|
|
20582
|
return $data; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
sub decode_chunk { |
574
|
5825
|
|
|
5825
|
|
11384
|
my ($self, $data) = @_; |
575
|
5825
|
|
|
|
|
10570
|
$data =~ tr/+/ /; |
576
|
5825
|
|
|
|
|
17896
|
$data =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge; |
|
6904
|
|
|
|
|
23170
|
|
577
|
5825
|
|
|
|
|
28519
|
return $data; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
package App::Muter::Backend::XML; |
583
|
|
|
|
|
|
|
$App::Muter::Backend::XML::VERSION = '0.002001'; |
584
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::ChunkedDecode/; |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
sub new { |
587
|
2416
|
|
|
2416
|
|
6975
|
my ($class, $args, %opts) = @_; |
588
|
2416
|
|
|
|
|
12096
|
my $self = $class->SUPER::new($args, %opts, regexp => qr/^(.*)(&[^;]*)$/); |
589
|
4
|
|
|
4
|
|
2975
|
no warnings 'qw'; ## no critic (ProhibitNoWarnings) |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
6422
|
|
590
|
2416
|
|
|
|
|
11113
|
my $maps = { |
591
|
|
|
|
|
|
|
default => [qw/quot amp apos lt gt/], |
592
|
|
|
|
|
|
|
html => [qw/quot amp #x27 lt gt/], |
593
|
|
|
|
|
|
|
hex => [qw/#x22 #x26 #x27 #x3c #x3e/], |
594
|
|
|
|
|
|
|
}; |
595
|
2416
|
|
100
|
|
|
8489
|
my $type = $args->[0] // 'default'; |
596
|
2416
|
50
|
|
|
|
6278
|
$type = 'default' unless exists $maps->{$type}; |
597
|
2416
|
|
|
|
|
4010
|
@{$self->{fmap}}{qw/" & ' < >/} = map { "&$_;" } @{$maps->{$type}}; |
|
2416
|
|
|
|
|
10958
|
|
|
12080
|
|
|
|
|
25810
|
|
|
2416
|
|
|
|
|
5506
|
|
598
|
2416
|
|
|
|
|
5122
|
@{$self->{rmap}}{@{$maps->{default}}} = qw/" & ' < >/; |
|
2416
|
|
|
|
|
8554
|
|
|
2416
|
|
|
|
|
4309
|
|
599
|
2416
|
|
|
|
|
12754
|
return $self; |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
sub metadata { |
603
|
4
|
|
|
4
|
|
10
|
my $self = shift; |
604
|
4
|
|
|
|
|
21
|
my $meta = $self->SUPER::metadata; |
605
|
|
|
|
|
|
|
return { |
606
|
4
|
|
|
|
|
22
|
%$meta, |
607
|
|
|
|
|
|
|
args => { |
608
|
|
|
|
|
|
|
default => 'Use XML entity names', |
609
|
|
|
|
|
|
|
html => 'Use HTML-friendly entity names for XML entities', |
610
|
|
|
|
|
|
|
hex => 'Use hexadecimal entity names for XML entities', |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
}; |
613
|
|
|
|
|
|
|
} |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
# XML encodes Unicode characters. However, muter only works on byte sequences, |
616
|
|
|
|
|
|
|
# so immediately encode these into UTF-8. |
617
|
|
|
|
|
|
|
sub _decode_char { |
618
|
569
|
|
|
569
|
|
1672
|
my ($self, $char) = @_; |
619
|
569
|
50
|
|
|
|
1858
|
return chr($1) if $char =~ /^#([0-9]+)$/; |
620
|
569
|
100
|
|
|
|
2480
|
return chr(hex($1)) if $char =~ /^#x([a-fA-F0-9]+)$/; |
621
|
309
|
50
|
|
|
|
1558
|
return $self->{rmap}{$char} if exists $self->{rmap}{$char}; |
622
|
0
|
|
|
|
|
0
|
die "Unknown XML entity &$char;"; |
623
|
|
|
|
|
|
|
} |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
sub encode_chunk { |
626
|
5733
|
|
|
5733
|
|
10278
|
my ($self, $data) = @_; |
627
|
5733
|
|
|
|
|
13853
|
$data =~ s/(["&'<>])/$self->{fmap}{$1}/ge; |
|
569
|
|
|
|
|
2275
|
|
628
|
5733
|
|
|
|
|
17136
|
return $data; |
629
|
|
|
|
|
|
|
} |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
sub decode_chunk { |
632
|
5974
|
|
|
5974
|
|
11111
|
my ($self, $data) = @_; |
633
|
5974
|
|
|
|
|
24523
|
require Encode; |
634
|
5974
|
|
|
|
|
37271
|
$data =~ s/&([^;]+);/Encode::encode('UTF-8', $self->_decode_char($1))/ge; |
|
569
|
|
|
|
|
5403
|
|
635
|
5974
|
|
|
|
|
47998
|
return $data; |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
package App::Muter::Backend::QuotedPrintable; |
641
|
|
|
|
|
|
|
$App::Muter::Backend::QuotedPrintable::VERSION = '0.002001'; |
642
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::ChunkedDecode/; |
643
|
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
sub new { |
645
|
806
|
|
|
806
|
|
2447
|
my ($class, $args, %opts) = @_; |
646
|
806
|
|
|
|
|
4451
|
my $self = |
647
|
|
|
|
|
|
|
$class->SUPER::new($args, %opts, regexp => qr/\A(.*)(=[^\n]?)\z/); |
648
|
806
|
|
|
|
|
2402
|
$self->{curlen} = 0; |
649
|
806
|
100
|
|
|
|
2424
|
$self->{smtp} = 1 if grep { $_ eq 'smtp' } @$args; |
|
28
|
|
|
|
|
99
|
|
650
|
806
|
|
|
|
|
3585
|
return $self; |
651
|
|
|
|
|
|
|
} |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
sub encode { |
654
|
2139
|
|
|
2139
|
|
3902
|
my ($self, $data) = @_; |
655
|
2139
|
|
|
|
|
4383
|
$data = $self->{chunk} . $data; |
656
|
2139
|
|
|
|
|
4090
|
$self->{chunk} = ''; |
657
|
2139
|
100
|
|
|
|
5327
|
if (length($data) < 7) { |
658
|
1655
|
|
|
|
|
2755
|
$self->{chunk} = $data; |
659
|
1655
|
|
|
|
|
5511
|
return ''; |
660
|
|
|
|
|
|
|
} |
661
|
484
|
100
|
|
|
|
1708
|
if ($data =~ /\A(.*)(\n.{0,6})\z/) { |
662
|
34
|
|
|
|
|
110
|
$self->{chunk} = $2; |
663
|
34
|
|
|
|
|
77
|
$data = $1; |
664
|
|
|
|
|
|
|
} |
665
|
484
|
|
|
|
|
1187
|
return $self->encode_chunk($data); |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
sub encode_final { |
669
|
508
|
|
|
508
|
|
1001
|
my ($self, $data) = @_; |
670
|
508
|
|
|
|
|
1622
|
$data = $self->{chunk} . $data; |
671
|
508
|
|
|
|
|
1048
|
$self->{chunk} = ''; |
672
|
508
|
|
|
|
|
1170
|
return $self->encode_chunk($data); |
673
|
|
|
|
|
|
|
} |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
sub encode_chunk { |
676
|
992
|
|
|
992
|
|
1879
|
my ($self, $data) = @_; |
677
|
992
|
|
|
|
|
3753
|
$data =~ s/([^\x20-\x3c\x3e-\x7e])/sprintf '=%02X', ord($1)/ge; |
|
2323
|
|
|
|
|
8758
|
|
678
|
992
|
100
|
|
|
|
2696
|
$data =~ s/(^|=0A)\./$1=2E/g if $self->{smtp}; |
679
|
992
|
100
|
|
|
|
2232
|
$data =~ s/(^|=0A)F(rom )/$1=46$2/g if $self->{smtp}; |
680
|
992
|
|
|
|
|
1728
|
my $result = ''; |
681
|
992
|
|
|
|
|
1589
|
my $maxlen = 75; |
682
|
992
|
|
|
|
|
2710
|
while ($self->{curlen} + length($data) > $maxlen) { |
683
|
12
|
|
|
|
|
29
|
my $chunk = substr($data, 0, $maxlen - $self->{curlen}); |
684
|
12
|
50
|
|
|
|
28
|
$chunk = $1 if $chunk =~ /^(.*)(=.?)$/; |
685
|
12
|
|
|
|
|
25
|
$data = substr($data, length($chunk)); |
686
|
12
|
|
|
|
|
27
|
$result .= $chunk; |
687
|
12
|
50
|
|
|
|
23
|
if ($data) { |
688
|
12
|
|
|
|
|
22
|
$result .= "=\n"; |
689
|
12
|
|
|
|
|
30
|
$self->{curlen} = 0; |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
} |
692
|
992
|
|
|
|
|
1932
|
$result .= $data; |
693
|
992
|
|
|
|
|
1650
|
$self->{curlen} += length($data); |
694
|
992
|
|
|
|
|
4190
|
return $result; |
695
|
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
sub decode_chunk { |
698
|
2230
|
|
|
2230
|
|
4272
|
my ($self, $data) = @_; |
699
|
2230
|
|
|
|
|
4259
|
$data =~ s/=\n//g; |
700
|
2230
|
|
|
|
|
4626
|
$data =~ s/=([0-9A-F]{2})/chr(hex($1))/ge; |
|
1209
|
|
|
|
|
4249
|
|
701
|
2230
|
|
|
|
|
9247
|
return $data; |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
sub metadata { |
705
|
4
|
|
|
4
|
|
7
|
my $self = shift; |
706
|
4
|
|
|
|
|
21
|
my $meta = $self->SUPER::metadata; |
707
|
|
|
|
|
|
|
return { |
708
|
4
|
|
|
|
|
17
|
%$meta, |
709
|
|
|
|
|
|
|
args => { |
710
|
|
|
|
|
|
|
smtp => 'Encode "." and "From " at beginning of line', |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
}; |
713
|
|
|
|
|
|
|
} |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
package App::Muter::Backend::Vis; |
718
|
|
|
|
|
|
|
$App::Muter::Backend::Vis::VERSION = '0.002001'; |
719
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::ChunkedDecode/; |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
sub new { |
722
|
3568
|
|
|
3568
|
|
13651
|
my ($class, $args, %opts) = @_; |
723
|
3568
|
|
|
|
|
32173
|
my $self = $class->SUPER::new($args, %opts, |
724
|
|
|
|
|
|
|
regexp => qr/\A(.*?[^^\\-])?(\\.{0,3})\z/); |
725
|
3568
|
|
|
|
|
13651
|
$self->_setup_maps(map { $_ => 1 } @$args); |
|
2428
|
|
|
|
|
11347
|
|
726
|
3568
|
|
|
|
|
14703
|
$self->{chunk} = ''; |
727
|
3568
|
|
|
|
|
35274
|
return $self; |
728
|
|
|
|
|
|
|
} |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
sub _setup_maps { |
731
|
3568
|
|
|
3568
|
|
11318
|
my ($self, %flags) = @_; |
732
|
3568
|
|
|
|
|
11540
|
$self->{flags} = \%flags; |
733
|
3568
|
|
|
|
|
24380
|
my $standard = {_id_map(0x21 .. 0x7e), 0x5c => "\\\\"}; |
734
|
3568
|
|
|
|
|
58385
|
my $default = {_meta_map(0x00 .. 0x20, 0x7f .. 0xff)}; |
735
|
3568
|
|
|
|
|
78176
|
my $octal = {_octal_map(0x00 .. 0x20, 0x7f .. 0xff)}; |
736
|
3568
|
|
|
|
|
281329
|
my $cstyle = { |
737
|
|
|
|
|
|
|
%$default, |
738
|
|
|
|
|
|
|
0x00 => "\\000", |
739
|
|
|
|
|
|
|
0x07 => "\\a", |
740
|
|
|
|
|
|
|
0x08 => "\\b", |
741
|
|
|
|
|
|
|
0x09 => "\\t", |
742
|
|
|
|
|
|
|
0x0a => "\\n", |
743
|
|
|
|
|
|
|
0x0b => "\\v", |
744
|
|
|
|
|
|
|
0x0c => "\\f", |
745
|
|
|
|
|
|
|
0x0d => "\\r", |
746
|
|
|
|
|
|
|
0x20 => "\\s", |
747
|
|
|
|
|
|
|
}; |
748
|
|
|
|
|
|
|
my $wanted_map = |
749
|
3568
|
100
|
|
|
|
37407
|
$flags{cstyle} ? $cstyle : $flags{octal} ? $octal : $default; |
|
|
100
|
|
|
|
|
|
750
|
|
|
|
|
|
|
my @chars = ( |
751
|
|
|
|
|
|
|
($flags{sp} || $flags{space} || $flags{white} ? () : (0x20)), |
752
|
|
|
|
|
|
|
($flags{tab} || $flags{white} ? () : (0x09)), |
753
|
3568
|
100
|
100
|
|
|
67389
|
($flags{nl} || $flags{white} ? () : (0x0a)), |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
754
|
|
|
|
|
|
|
); |
755
|
3568
|
100
|
|
|
|
14476
|
my %glob_chars = _octal_map($flags{glob} ? (0x23, 0x2a, 0x3f, 0x5b) : ()); |
756
|
3568
|
|
|
|
|
11148
|
my $extras = {_id_map(0x09, 0x0a, 0x20)}; |
757
|
3568
|
|
|
|
|
104815
|
my $map = {%$standard, %$wanted_map, %glob_chars, _id_map(@chars)}; |
758
|
3568
|
|
|
|
|
121512
|
$self->{map} = [map { $map->{$_} } sort { $a <=> $b } keys %$map]; |
|
913408
|
|
|
|
|
1737649
|
|
|
6176839
|
|
|
|
|
8012361
|
|
759
|
|
|
|
|
|
|
$self->{rmap} = { |
760
|
3568
|
|
|
|
|
1081694
|
reverse(%$standard), reverse(%$wanted_map), |
761
|
|
|
|
|
|
|
reverse(%$extras), reverse(%$octal), |
762
|
|
|
|
|
|
|
reverse(%$cstyle), reverse(%glob_chars), |
763
|
|
|
|
|
|
|
"\\0" => 0x00 |
764
|
|
|
|
|
|
|
}; |
765
|
3568
|
|
|
|
|
340606
|
return; |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
sub _id_map { ## no critic(RequireArgUnpacking) |
769
|
10704
|
|
|
10704
|
|
82462
|
return map { $_ => chr($_) } @_; |
|
354322
|
|
|
|
|
1070021
|
|
770
|
|
|
|
|
|
|
} |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
sub _octal_map { ## no critic(RequireArgUnpacking) |
773
|
7136
|
|
|
7136
|
|
22631
|
return map { $_ => sprintf('\%03o', $_) } @_; |
|
578040
|
|
|
|
|
1335902
|
|
774
|
|
|
|
|
|
|
} |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
sub _meta_map { ## no critic(RequireArgUnpacking) |
777
|
3568
|
|
|
3568
|
|
9732
|
return map { $_ => _encode($_) } @_; |
|
578016
|
|
|
|
|
1034582
|
|
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
sub _encode { |
781
|
578016
|
|
|
578016
|
|
890245
|
my ($byte) = @_; |
782
|
4
|
|
|
4
|
|
44
|
use bytes; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
22
|
|
783
|
578016
|
|
|
|
|
806887
|
my $ascii = $byte & 0x7f; |
784
|
578016
|
|
|
|
|
862618
|
for ($byte) { |
785
|
578016
|
|
|
|
|
1770983
|
when ([0x00 .. 0x1f, 0x7f]) { return '\^' . chr($ascii ^ 0x40) } |
|
117744
|
|
|
|
|
337941
|
|
786
|
460272
|
|
|
|
|
1546860
|
when ([0x80 .. 0x9f, 0xff]) { return '\M^' . chr($ascii ^ 0x40) } |
|
117744
|
|
|
|
|
658486
|
|
787
|
342528
|
|
|
|
|
1617642
|
when ([0xa1 .. 0xfe]) { return '\M-' . chr($ascii) } |
|
335392
|
|
|
|
|
1123107
|
|
788
|
7136
|
|
|
|
|
20766
|
when (0x20) { return '\040' } |
|
3568
|
|
|
|
|
9501
|
|
789
|
3568
|
|
|
|
|
6874
|
when (0xa0) { return '\240' } |
|
3568
|
|
|
|
|
8672
|
|
790
|
0
|
|
|
|
|
0
|
default { die sprintf 'Found byte value %#02x', $byte; } |
|
0
|
|
|
|
|
0
|
|
791
|
|
|
|
|
|
|
} |
792
|
0
|
|
|
|
|
0
|
return; |
793
|
|
|
|
|
|
|
} |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
sub encode { |
796
|
10913
|
|
|
10913
|
|
21696
|
my ($self, $data) = @_; |
797
|
10913
|
|
|
|
|
23547
|
$data = $self->{chunk} . $data; |
798
|
10913
|
100
|
100
|
|
|
52309
|
if (length $data && substr($data, -1) eq "\0") { |
799
|
425
|
|
|
|
|
1104
|
$data = substr($data, 0, -1); |
800
|
425
|
|
|
|
|
1009
|
$self->{chunk} = "\0"; |
801
|
|
|
|
|
|
|
} |
802
|
|
|
|
|
|
|
else { |
803
|
10488
|
|
|
|
|
20518
|
$self->{chunk} = ''; |
804
|
|
|
|
|
|
|
} |
805
|
10913
|
|
|
|
|
27734
|
return $self->SUPER::encode($data); |
806
|
|
|
|
|
|
|
} |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
sub encode_chunk { |
809
|
12706
|
|
|
12706
|
|
23370
|
my ($self, $data) = @_; |
810
|
12706
|
|
|
|
|
40771
|
my $result = join('', map { $self->{map}[$_] } unpack('C*', $data)); |
|
25227
|
|
|
|
|
60506
|
|
811
|
12706
|
100
|
|
|
|
37099
|
if ($self->{flags}{cstyle}) { |
812
|
|
|
|
|
|
|
# Do this twice to fix multiple consecutive NUL bytes. |
813
|
3171
|
|
|
|
|
14696
|
$result =~ s/\\000($|[^0-7])/\\0$1/g for 1 .. 2; |
814
|
|
|
|
|
|
|
} |
815
|
12706
|
|
|
|
|
41800
|
return $result; |
816
|
|
|
|
|
|
|
} |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
sub _decode { |
819
|
25849
|
|
|
25849
|
|
45857
|
my ($self, $val) = @_; |
820
|
4
|
|
|
4
|
|
1693
|
use bytes; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
18
|
|
821
|
25849
|
100
|
|
|
|
62223
|
return '' if !length $val; |
822
|
16080
|
100
|
50
|
|
|
90184
|
return chr($self->{rmap}{$val} // die "val '$_'") if $val =~ /^\\/; |
823
|
5251
|
|
|
|
|
14196
|
return pack('C*', map { $self->{rmap}{$_} } split //, $val); |
|
9754
|
|
|
|
|
54396
|
|
824
|
|
|
|
|
|
|
} |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
sub decode_chunk { |
827
|
10560
|
|
|
10560
|
|
21720
|
my ($self, $data) = @_; |
828
|
|
|
|
|
|
|
return join('', |
829
|
10560
|
|
|
|
|
53909
|
map { $self->_decode($_) } |
|
25849
|
|
|
|
|
54450
|
|
830
|
|
|
|
|
|
|
split /(\\(?:M[-^].|\^.|[0-7]{3}|\\|[0abtnvfrs]))/, |
831
|
|
|
|
|
|
|
$data); |
832
|
|
|
|
|
|
|
} |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
sub metadata { |
835
|
4
|
|
|
4
|
|
8
|
my $self = shift; |
836
|
4
|
|
|
|
|
15
|
my $meta = $self->SUPER::metadata; |
837
|
|
|
|
|
|
|
return { |
838
|
4
|
|
|
|
|
35
|
%$meta, |
839
|
|
|
|
|
|
|
args => { |
840
|
|
|
|
|
|
|
sp => 'Encode space', |
841
|
|
|
|
|
|
|
space => 'Encode space', |
842
|
|
|
|
|
|
|
tab => 'Encode tab', |
843
|
|
|
|
|
|
|
nl => 'Encode newline', |
844
|
|
|
|
|
|
|
white => 'Encode space, tab, and newline', |
845
|
|
|
|
|
|
|
cstyle => 'Encode using C-like escape sequences', |
846
|
|
|
|
|
|
|
octal => 'Encode using octal escape sequences', |
847
|
|
|
|
|
|
|
glob => 'Encode characters recognized by glob(3) and hash mark', |
848
|
|
|
|
|
|
|
} |
849
|
|
|
|
|
|
|
}; |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
package App::Muter::Backend::Ascii85; |
855
|
|
|
|
|
|
|
$App::Muter::Backend::Ascii85::VERSION = '0.002001'; |
856
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend::Chunked/; |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
sub new { |
859
|
734
|
|
|
734
|
|
1791
|
my ($class, @args) = @_; |
860
|
734
|
|
|
|
|
2016
|
my $self = $class->SUPER::new(@args, enchunksize => 4, dechunksize => 5); |
861
|
734
|
|
|
|
|
1404
|
$self->{start} = ''; |
862
|
734
|
|
|
|
|
2815
|
return $self; |
863
|
|
|
|
|
|
|
} |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
sub encode { |
866
|
1150
|
|
|
1150
|
|
1911
|
my ($self, $data) = @_; |
867
|
1150
|
100
|
|
|
|
2461
|
return '' unless length $data; |
868
|
1149
|
100
|
|
|
|
2456
|
my $prefix = defined $self->{start} ? '<~' : ''; |
869
|
1149
|
|
|
|
|
1797
|
$self->{start} = undef; |
870
|
1149
|
|
|
|
|
2439
|
return $prefix . $self->SUPER::encode($data); |
871
|
|
|
|
|
|
|
} |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
sub encode_final { |
874
|
367
|
|
|
367
|
|
643
|
my ($self, $data) = @_; |
875
|
|
|
|
|
|
|
return $self->SUPER::encode_final($data) . |
876
|
367
|
100
|
|
|
|
837
|
(defined $self->{start} ? '' : '~>'); |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
sub _encode_seq { |
880
|
849
|
|
|
849
|
|
1454
|
my ($x, $flag) = @_; |
881
|
849
|
100
|
100
|
|
|
2166
|
return (89) if !$x && !$flag; |
882
|
823
|
|
|
|
|
1154
|
my @res; |
883
|
823
|
|
|
|
|
1662
|
for (0 .. 4) { |
884
|
4115
|
|
|
|
|
5818
|
push @res, $x % 85; |
885
|
4115
|
|
|
|
|
6787
|
$x = int($x / 85); |
886
|
|
|
|
|
|
|
} |
887
|
823
|
|
|
|
|
3038
|
return reverse @res; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
sub encode_chunk { |
891
|
1516
|
|
|
1516
|
|
3020
|
my (undef, $data) = @_; |
892
|
1516
|
|
|
|
|
2495
|
my $rem = length($data) % 4; |
893
|
1516
|
100
|
|
|
|
2857
|
my $pad = $rem ? (4 - $rem) : 0; |
894
|
1516
|
|
|
|
|
2655
|
$data .= "\0" x $pad; |
895
|
1516
|
|
|
|
|
3941
|
my @chunks = unpack("N*", $data); |
896
|
1516
|
100
|
|
|
|
3207
|
my @last = $pad ? (pop @chunks) : (); |
897
|
1516
|
|
|
|
|
3105
|
my $res = pack('C*', map { _encode_seq($_) } @chunks); |
|
589
|
|
|
|
|
1100
|
|
898
|
1516
|
|
|
|
|
2996
|
$res .= pack('C*', map { _encode_seq($_, 1) } @last); |
|
260
|
|
|
|
|
529
|
|
899
|
1516
|
|
|
|
|
2740
|
$res =~ tr/\x00-\x54\x59/!-uz/; |
900
|
1516
|
100
|
|
|
|
3646
|
$res = substr($res, 0, -$pad) if $pad; |
901
|
1516
|
|
|
|
|
6909
|
return $res; |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
sub decode { |
905
|
1350
|
|
|
1350
|
|
2197
|
my ($self, $data) = @_; |
906
|
|
|
|
|
|
|
|
907
|
1350
|
100
|
|
|
|
3664
|
return '' unless length $data; |
908
|
|
|
|
|
|
|
|
909
|
995
|
100
|
|
|
|
2220
|
if (defined $self->{start}) { |
910
|
489
|
|
|
|
|
904
|
$self->{start} .= $data; |
911
|
489
|
100
|
|
|
|
1803
|
return '' unless length $self->{start} > 2; |
912
|
|
|
|
|
|
|
|
913
|
288
|
50
|
|
|
|
1509
|
($data = $self->{start}) =~ s/^<~// or die 'Invalid Ascii85 prefix'; |
914
|
288
|
|
|
|
|
607
|
$self->{start} = undef; |
915
|
|
|
|
|
|
|
} |
916
|
794
|
|
|
|
|
2025
|
return $self->decode_chunk($self->{chunk} . $data); |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
sub _decode_seq { |
920
|
849
|
|
|
849
|
|
2104
|
my ($s) = @_; |
921
|
849
|
100
|
|
|
|
1980
|
return 0 if $s eq 'z'; |
922
|
823
|
50
|
|
|
|
1753
|
die 'Invalid Ascii85 encoding' if $s gt 's8W-!'; |
923
|
823
|
|
|
4115
|
|
4229
|
my $val = List::Util::reduce { $a * 85 + ($b - 33) } (0, unpack('C*', $s)); |
|
4115
|
|
|
|
|
6323
|
|
924
|
823
|
|
|
|
|
3719
|
return $val; |
925
|
|
|
|
|
|
|
} |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
sub decode_chunk { |
928
|
1502
|
|
|
1502
|
|
2684
|
my ($self, $data) = @_; |
929
|
1502
|
|
|
|
|
2020
|
my @chunks; |
930
|
1502
|
|
|
|
|
6060
|
push @chunks, _decode_seq($1) while $data =~ s/^(z|[^~]{5})//s; |
931
|
1502
|
|
|
|
|
2768
|
$self->{chunk} = $data; |
932
|
1502
|
|
|
|
|
5645
|
return pack('N*', @chunks); |
933
|
|
|
|
|
|
|
} |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
sub decode_final { |
936
|
367
|
|
|
367
|
|
650
|
my ($self, $data) = @_; |
937
|
367
|
|
|
|
|
779
|
$data = $self->{chunk} . $data; |
938
|
367
|
100
|
100
|
|
|
1325
|
return '' if defined $self->{start} && !length $data; |
939
|
354
|
|
|
|
|
771
|
my $res = $self->decode_chunk($data); |
940
|
354
|
|
|
|
|
640
|
$data = $self->{chunk}; |
941
|
354
|
50
|
|
|
|
1534
|
$data =~ s/~>$// or die "Missing Ascii85 trailer"; |
942
|
354
|
|
|
|
|
737
|
my $rem = length($data) % 5; |
943
|
354
|
100
|
|
|
|
756
|
my $pad = $rem ? (5 - $rem) : 0; |
944
|
354
|
|
|
|
|
1047
|
$res .= $self->decode_chunk($data . 'u' x $pad); |
945
|
354
|
100
|
|
|
|
1057
|
$res = substr($res, 0, -$pad) if $pad; |
946
|
354
|
|
|
|
|
1544
|
return $res; |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
package App::Muter::Backend::Hash; |
952
|
|
|
|
|
|
|
$App::Muter::Backend::Hash::VERSION = '0.002001'; |
953
|
4
|
|
|
4
|
|
4621
|
use Digest::MD5; |
|
4
|
|
|
|
|
12
|
|
|
4
|
|
|
|
|
296
|
|
954
|
4
|
|
|
4
|
|
1832
|
use Digest::SHA; |
|
4
|
|
|
|
|
8363
|
|
|
4
|
|
|
|
|
2267
|
|
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
our @ISA = qw/App::Muter::Backend/; |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
my $hashes = {}; |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
sub new { |
961
|
56
|
|
|
56
|
|
232
|
my ($class, $args, @args) = @_; |
962
|
56
|
|
|
|
|
136
|
my ($hash) = @$args; |
963
|
56
|
|
|
|
|
274
|
my $self = $class->SUPER::new($args, @args); |
964
|
56
|
|
|
|
|
219
|
$self->{hash} = $hashes->{$hash}->(); |
965
|
56
|
|
|
|
|
1267
|
return $self; |
966
|
|
|
|
|
|
|
} |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
sub encode { |
969
|
3949
|
|
|
3949
|
|
6884
|
my ($self, $data) = @_; |
970
|
3949
|
|
|
|
|
13374
|
$self->{hash}->add($data); |
971
|
3949
|
|
|
|
|
9179
|
return ''; |
972
|
|
|
|
|
|
|
} |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
sub encode_final { |
975
|
56
|
|
|
56
|
|
143
|
my ($self, $data) = @_; |
976
|
56
|
|
|
|
|
281
|
$self->{hash}->add($data); |
977
|
56
|
|
|
|
|
438
|
return $self->{hash}->digest; |
978
|
|
|
|
|
|
|
} |
979
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
sub metadata { |
981
|
4
|
|
|
4
|
|
11
|
my ($self, $data) = @_; |
982
|
4
|
|
|
|
|
23
|
my $meta = $self->SUPER::metadata; |
983
|
4
|
|
|
|
|
19
|
$meta->{args} = {map { $_ => "Use the $_ hash algorithm" } keys %$hashes}; |
|
40
|
|
|
|
|
122
|
|
984
|
4
|
|
|
|
|
13
|
return $meta; |
985
|
|
|
|
|
|
|
} |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
sub register_hash { |
988
|
40
|
|
|
40
|
|
69
|
my ($name, $code) = @_; |
989
|
40
|
50
|
|
|
|
92
|
return $hashes->{$name} unless $code; |
990
|
40
|
|
|
|
|
83
|
return $hashes->{$name} = $code; |
991
|
|
|
|
|
|
|
} |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
register_hash('md5', sub { Digest::MD5->new }); |
994
|
|
|
|
|
|
|
register_hash('sha1', sub { Digest::SHA->new }); |
995
|
|
|
|
|
|
|
register_hash('sha224', sub { Digest::SHA->new(224) }); |
996
|
|
|
|
|
|
|
register_hash('sha256', sub { Digest::SHA->new(256) }); |
997
|
|
|
|
|
|
|
register_hash('sha384', sub { Digest::SHA->new(384) }); |
998
|
|
|
|
|
|
|
register_hash('sha512', sub { Digest::SHA->new(512) }); |
999
|
|
|
|
|
|
|
register_hash('sha3-224', sub { require Digest::SHA3; Digest::SHA3->new(224) }); |
1000
|
|
|
|
|
|
|
register_hash('sha3-256', sub { require Digest::SHA3; Digest::SHA3->new(256) }); |
1001
|
|
|
|
|
|
|
register_hash('sha3-384', sub { require Digest::SHA3; Digest::SHA3->new(384) }); |
1002
|
|
|
|
|
|
|
register_hash('sha3-512', sub { require Digest::SHA3; Digest::SHA3->new(512) }); |
1003
|
|
|
|
|
|
|
App::Muter::Registry->instance->register(__PACKAGE__); |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
__END__ |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
=pod |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
=encoding UTF-8 |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
=head1 NAME |
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
App::Muter - tool to convert between various formats and encodings |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
=head1 VERSION |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
version 0.002001 |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
=head1 DESCRIPTION |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
App::Muter provides the C<muter> command, which converts data between various |
1022
|
|
|
|
|
|
|
formats. |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
For more information, see L<muter(1)>. |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
=head1 AUTHOR |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
brian m. carlson <sandals@crustytoothpaste.net> |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
This software is Copyright (c) 2016â2017 by brian m. carlson. |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
This is free software, licensed under: |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
The MIT (X11) License |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
=cut |