File Coverage

blib/lib/Mail/Milter/Authentication/HTDocs.pm
Criterion Covered Total %
statement 11 44 25.0
branch 0 12 0.0
condition n/a
subroutine 4 8 50.0
pod 4 4 100.0
total 19 68 27.9


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::HTDocs;
2 126     126   2726 use 5.20.0;
  126         415  
3 126     126   647 use strict;
  126         435  
  126         2718  
4 126     126   643 use warnings;
  126         315  
  126         3054  
5 126     126   650 use Mail::Milter::Authentication::Pragmas;
  126         485  
  126         868  
6             # ABSTRACT: Load and serve static files via the in-built http server.
7             our $VERSION = '3.20230629'; # VERSION
8              
9              
10              
11             sub new {
12 0     0 1   my ( $class ) = @_;
13 0           my $self = {};
14 0           bless $self, $class;
15 0           return $self;
16             }
17              
18              
19             sub get_whitelist {
20 0     0 1   my ( $self, $path ) = @_;
21              
22 0           my @whitelist;
23              
24 0 0         if ( opendir( my $dh, join( '/', $self->get_basedir(), $path ) ) ) {
25 0           while ( my $file = readdir( $dh ) ) {
26 0 0         next if $file =~ /^\./;
27 0           my $full_path = join( '/', $self->get_basedir(), $path, $file );
28 0 0         if ( -f $full_path ) {
29 0           push @whitelist, join( '/', $path, $file );
30             }
31 0 0         if ( -d $full_path ) {
32 0           @whitelist = ( @whitelist, @{ $self->get_whitelist( join ( '/', $path, $file ) ) } );
  0            
33             }
34             }
35             }
36              
37 0           return \@whitelist;
38             }
39              
40              
41             sub get_basedir {
42 0     0 1   my ( $self ) = @_;
43 0           my $basedir = __FILE__;
44 0           $basedir =~ s/HTDocs\.pm$/htdocs/;
45 0           return $basedir;
46             }
47              
48              
49             sub get_file {
50 0     0 1   my ( $self, $file ) = @_;
51              
52 0           my $whitelisted = grep { $_ eq $file } @{ $self->get_whitelist( '' ) };
  0            
  0            
53 0 0         return if ! $whitelisted;
54              
55 0           my $basefile = $self->get_basedir();
56 0           $basefile .= $file;
57 0 0         if ( ! -e $basefile ) {
58 0           return;
59             }
60 0           open my $InF, '<', $basefile;
61 0           my @Content = <$InF>;
62 0           close $InF;
63 0           return join( q{}, @Content );
64             }
65              
66             1;
67              
68             __END__
69              
70             =pod
71              
72             =encoding UTF-8
73              
74             =head1 NAME
75              
76             Mail::Milter::Authentication::HTDocs - Load and serve static files via the in-built http server.
77              
78             =head1 VERSION
79              
80             version 3.20230629
81              
82             =head1 DESCRIPTION
83              
84             Load and serve static files via the in-build http server.
85              
86             =head1 CONSTRUCTOR
87              
88             =head2 I<new()>
89              
90             Return a new instance of this class
91              
92             =head1 METHODS
93              
94             =head2 I<get_whitelist()>
95              
96             Return an arrayref of valid URLs/Filenames whih are allowed to be served.
97              
98             =head2 I<get_basedir()>
99              
100             Return the base directory for htdocs files
101              
102             =head2 I<get_file( $file )>
103              
104             Return a full HTTP response for the given filename, or null if it does not exist.
105              
106             =head1 AUTHOR
107              
108             Marc Bradshaw <marc@marcbradshaw.net>
109              
110             =head1 COPYRIGHT AND LICENSE
111              
112             This software is copyright (c) 2020 by Marc Bradshaw.
113              
114             This is free software; you can redistribute it and/or modify it under
115             the same terms as the Perl 5 programming language system itself.
116              
117             =cut