File Coverage

blib/lib/Mail/Milter/Authentication/App/Blocker/App/Command/list.pm
Criterion Covered Total %
statement 23 60 38.3
branch 0 10 0.0
condition n/a
subroutine 8 13 61.5
pod 5 5 100.0
total 36 88 40.9


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::App::Blocker::App::Command::list;
2 1     1   105232 use 5.20.0;
  1         4  
3 1     1   6 use strict;
  1         2  
  1         22  
4 1     1   5 use warnings;
  1         2  
  1         26  
5 1     1   469 use Mail::Milter::Authentication::Pragmas;
  1         3  
  1         9  
6             # ABSTRACT: Command to list current blocks for a given file
7             our $VERSION = '3.20230911'; # VERSION
8 1     1   782 use Mail::Milter::Authentication::App::Blocker::App -command;
  1         3  
  1         9  
9 1     1   7289 use Date::Format;
  1         9774  
  1         88  
10 1     1   10 use TOML;
  1         3  
  1         53  
11 1     1   699 use Text::Table;
  1         18680  
  1         523  
12              
13 0     0 1   sub abstract { 'List current blocks in a given file' }
14 0     0 1   sub description { 'Parse a toml file and list the current blocks' }
15              
16             sub opt_spec {
17             return (
18 0     0 1   [ 'file=s@', 'Config files to operate on' ],
19             );
20             }
21              
22 0     0 1   sub validate_args($self,$opt,$args) {
  0            
  0            
  0            
  0            
23             # no args allowed but options!
24 0 0         $self->usage_error('Must supply a filename') if ( !$opt->{file} );
25 0           foreach my $file ( $opt->{file}->@* ) {
26 0 0         $self->usage_error('Supplied filename does not exist') if ( ! -e $file );
27             }
28 0 0         $self->usage_error('No args allowed') if @$args;
29             }
30              
31 0     0 1   sub execute($self,$opt,$args) {
  0            
  0            
  0            
  0            
32              
33 0           foreach my $file ( $opt->{file}->@* ) {
34              
35 0           say "In file $file";
36 0           say '';
37              
38 0           open ( my $inf, '<', $file );
39 0           my $body = do { local $/; <$inf> };
  0            
  0            
40 0           close $inf;
41 0           my ( $data, $error ) = from_toml( $body );
42              
43 0 0         if ( $error ) {
44 0           say 'Error parsing file';
45 0           say $error;
46 0           exit 1;
47             }
48              
49 0           my $tb = Text::Table->new(
50             'Id',
51             'Callback',
52             'Value',
53             'With',
54             'Percent',
55             'Until',
56             );
57              
58 0           foreach my $key ( sort keys $data->%* ) {
59             $tb->add(
60             $key,
61             $data->{$key}->{callback},
62             $data->{$key}->{value},
63             $data->{$key}->{with},
64             $data->{$key}->{percent},
65 0 0         $data->{$key}->{until} ? time2str('%C',$data->{$key}->{until}) : '-',
66             );
67             }
68              
69 0           print $tb->title;
70 0           print $tb->rule('-');
71 0           print $tb->body;
72 0           say '';
73             }
74             }
75              
76             1;
77              
78             __END__
79              
80             =pod
81              
82             =encoding UTF-8
83              
84             =head1 NAME
85              
86             Mail::Milter::Authentication::App::Blocker::App::Command::list - Command to list current blocks for a given file
87              
88             =head1 VERSION
89              
90             version 3.20230911
91              
92             =head1 AUTHOR
93              
94             Marc Bradshaw <marc@marcbradshaw.net>
95              
96             =head1 COPYRIGHT AND LICENSE
97              
98             This software is copyright (c) 2020 by Marc Bradshaw.
99              
100             This is free software; you can redistribute it and/or modify it under
101             the same terms as the Perl 5 programming language system itself.
102              
103             =cut