File Coverage

lib/App/Muter.pm
Criterion Covered Total %
statement 497 540 92.0
branch 108 136 79.4
condition 33 46 71.7
subroutine 107 113 94.6
pod n/a
total 745 835 89.2


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