File Coverage

blib/lib/Apache2/SSI/Common.pm
Criterion Covered Total %
statement 86 108 79.6
branch 29 56 51.7
condition 9 25 36.0
subroutine 14 15 93.3
pod 3 3 100.0
total 141 207 68.1


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Apache2 Server Side Include Parser - ~/lib/Apache2/SSI/Common.pm
3             ## Version v0.1.0
4             ## Copyright(c) 2021 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2021/01/13
7             ## Modified 2021/01/13
8             ## All rights reserved
9             ##
10             ## This program is free software; you can redistribute it and/or modify it
11             ## under the same terms as Perl itself.
12             ##----------------------------------------------------------------------------
13             package Apache2::SSI::Common;
14             BEGIN
15             {
16 17     17   121453 use strict;
  17         45  
  17         530  
17 17     17   80 use warnings;
  17         35  
  17         475  
18 17     17   623 use parent qw( Module::Generic );
  17         408  
  17         92  
19 17     17   47905587 use IO::File;
  17         35  
  17         2570  
20 17     17   253 use Nice::Try;
  17         30  
  17         182  
21 17     17   3935929 use Scalar::Util ();
  17         46  
  17         645  
22 17     17   2398 use URI;
  17         12322  
  17         1663  
23 17     17   5921 our $VERSION = 'v0.1.0';
24             };
25              
26             ## RFC 3986 section 5.2.4
27             sub collapse_dots
28             {
29 481     481 1 10803 my $self = shift( @_ );
30 481         855 my $path = shift( @_ );
31 481 50       1326 return( '' ) if( !length( $path ) );
32 481         2288 my $u = URI->new( $path );
33 481         28475 $path = $u->path;
34 481         7166 my @new = ();
35 481         918 my $len = length( $path );
36            
37             ## "If the input buffer begins with a prefix of "../" or "./", then remove that prefix from the input buffer"
38 481 100 66     5468 if( substr( $path, 0, 2 ) eq './' )
    50 33        
    50          
    50          
    50          
    100          
39             {
40 1         4 substr( $path, 0, 2 ) = '';
41             ## $self->message( 3, "Removed './'. Path is now '", substr( $path, 0 ), "'." );
42             }
43             elsif( substr( $path, 0, 3 ) eq '../' )
44             {
45 0         0 substr( $path, 0, 3 ) = '';
46             }
47             ## "if the input buffer begins with a prefix of "/./" or "/.", where "." is a complete path segment, then replace that prefix with "/" in the input buffer"
48             elsif( substr( $path, 0, 3 ) eq '/./' )
49             {
50 0         0 substr( $path, 0, 3 ) = '/';
51             }
52             elsif( substr( $path, 0, 2 ) eq '/.' && 2 == $len )
53             {
54 0         0 substr( $path, 0, 2 ) = '/';
55             }
56             elsif( $path eq '..' || $path eq '.' )
57             {
58 0         0 $path = '';
59             }
60             elsif( $path eq '/' )
61             {
62 6         42 return( $u );
63             }
64            
65             ## -1 is used to ensure trailing blank entries do not get removed
66 475         2210 my @segments = split( '/', $path, -1 );
67             ## $self->messagef( 3, "Found %d segments.", scalar( @segments ) );
68 475         1506 for( my $i = 0; $i < scalar( @segments ); $i++ )
69             {
70 2358         3318 my $segment = $segments[$i];
71             ## "if the input buffer begins with a prefix of "/../" or "/..", where ".." is a complete path segment, then replace that prefix with "/" in the input buffer and remove the last segment and its preceding "/" (if any) from the output buffer"
72 2358 100       3973 if( $segment eq '..' )
    100          
73             {
74 19         50 pop( @new );
75             }
76             elsif( $segment eq '.' )
77             {
78 2         5 next;
79             }
80             else
81             {
82 2337 50       5643 push( @new, ( defined( $segment ) ? $segment : '' ) );
83             }
84             }
85             ## Finally, the output buffer is returned as the result of remove_dot_segments.
86 475         1521 my $new_path = join( '/', @new );
87 475 100       1306 substr( $new_path, 0, 0 ) = '/' unless( substr( $new_path, 0, 1 ) eq '/' );
88 475         1341 $u->path( $new_path );
89 475         16693 return( $u );
90             }
91              
92             ## Credits: Path::Tiny
93             sub slurp
94             {
95 58     58 1 152 my $self = shift( @_ );
96 58         121 my $args = {};
97 17     17   137 no warnings 'uninitialized';
  17         32  
  17         9256  
98 58 0       338 $args = Scalar::Util::reftype( $_[0] ) eq 'HASH'
    50          
99             ? shift( @_ )
100             : !( scalar( @_ ) % 2 )
101             ? { @_ }
102             : {};
103 58   0     177 my $file = $args->{filename} || $args->{file} || $self->filename;
104 58 50       503 return( $self->error( "No filename found." ) ) if( !length( $file ) );
105 58   50     446 my $binmode = $args->{binmode} // '';
106 58         161 try
107 58     58   97 {
108 58   50     183 my $fh = IO::File->new( "<$file" ) ||
109             return( $self->error( "Unable to open file \"$file\" in read mode: $!" ) );
110 58 50       9570 $fh->binmode( $binmode ) if( length( $binmode ) );
111 58         1030 my $size;
112 58 50 33     310 if( $binmode eq ':unix' && ( $size = -s( $fh ) ) )
113             {
114 0         0 my $buf;
115 0         0 $fh->read( $buf, $size );
116 0         0 return( $buf );
117             }
118             else
119             {
120 58         299 local $/;
121 58         3054 return( scalar( <$fh> ) );
122             }
123             }
124 58 50       529 catch( $e )
  0 50       0  
  58 50       172  
  58 0       131  
  58 50       154  
  58         94  
  58         102  
  58         136  
  58         229  
  0         0  
  58         127  
  0         0  
  58         374  
  58         184  
  58         160  
  58         222  
  0         0  
  0         0  
  0         0  
  0         0  
125 0     0   0 {
126 0         0 return( $self->error( "An error occured while trying to open and read file \"$file\": $e" ) );
127 0 0 33     0 }
  0 0 33     0  
  0 50       0  
  0 50       0  
  0         0  
  0         0  
  58         675  
  58         1569  
128             }
129              
130             sub slurp_utf8
131             {
132 58     58 1 568 my $self = shift( @_ );
133 58         144 my $args = {};
134 17     17   130 no warnings 'uninitialized';
  17         28  
  17         2164  
135 58 50       583 $args = Scalar::Util::reftype( $_[0] ) eq 'HASH'
    50          
136             ? shift( @_ )
137             : !( scalar( @_ ) % 2 )
138             ? { @_ }
139             : {};
140 58         265 $args->{binmode} = ':utf8';
141 58   33     520 my $file = $args->{filename} || $args->{file} || $self->filename;
142 58 50       374 return( $self->error( "No filename found." ) ) if( !length( $file ) );
143 58         383 $args->{filename} = $file;
144 58         316 return( $self->slurp( $args ) );
145             }
146              
147              
148             1;
149              
150             __END__
151              
152             =encoding utf-8
153              
154             =head1 NAME
155              
156             Apache2::SSI::Common - Apache2 Server Side Include Common Resources
157              
158             =head1 VERSION
159              
160             v0.1.0
161              
162             =head1 SYNOPSIS
163              
164             use parent qw( Apache2::SSI::Common );
165              
166             =head1 DESCRIPTION
167              
168             There is no specific api for this. This module contains only common resources used by other modules in this distribution.
169              
170             =head1 METHODS
171              
172             =head2 collapse_dots
173              
174             Provided with an uri, and this will resolve the path and removing the dots, such as C<.> and C<..> and return an L<URI> object.
175              
176             This is done as per the L<RFC 3986 section 5.2.4 algorithm|https://tools.ietf.org/html/rfc3986#page-33>
177              
178             my $uri = $ssi->collapse_dots( '/../a/b/../c/./d.html' );
179             # would become /a/c/d.html
180             my $uri = $ssi->collapse_dots( '/../a/b/../c/./d.html?foo=../bar' );
181             # would become /a/c/d.html?foo=../bar
182             $uri->query # foo=../bar
183              
184             =head2 slurp
185              
186             It returns the content of the L</filename>
187              
188             it takes an hash reference of parameters:
189              
190             =over 4
191              
192             =item I<binmode>
193              
194             my $content = $uri->slurp({ binmode => ':utf-8' });
195              
196             =back
197              
198             It will return undef and sets an L<Module::Generic/error> if there is no L</filename> value set or if the file cannot be opened.
199              
200             =head2 slurp_utf8
201              
202             It returns the content of the file L</filename> utf-8 decoded.
203              
204             This is equivalent to:
205              
206             my $content = $uri->slurp({ binmode => ':utf8' });
207              
208             C<:utf8> is slightly a bit more lax than C<:utf-8>, so it you want strict utf8, you can do:
209              
210             my $content = $uri->slurp({ binmode => ':utf-8' });
211              
212             =head1 AUTHOR
213              
214             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
215              
216             CPAN ID: jdeguest
217              
218             L<https://git.deguest.jp/jack/Apache2-SSI>
219              
220             =head1 SEE ALSO
221              
222             L<Apache2::SSI::File>, L<Apache2::SSI::URI>
223              
224             =head1 COPYRIGHT & LICENSE
225              
226             Copyright (c) 2020-2021 DEGUEST Pte. Ltd.
227              
228             You can use, copy, modify and redistribute this package and associated
229             files under the same terms as Perl itself.
230              
231             =cut
232