File Coverage

blib/lib/Dancer2/FileUtils.pm
Criterion Covered Total %
statement 55 55 100.0
branch 12 14 85.7
condition n/a
subroutine 17 17 100.0
pod 8 9 88.8
total 92 95 96.8


line stmt bran cond sub pod time code
1             package Dancer2::FileUtils;
2             # ABSTRACT: File utility helpers
3             $Dancer2::FileUtils::VERSION = '1.0.0';
4 156     156   160487 use strict;
  156         390  
  156         4569  
5 156     156   876 use warnings;
  156         357  
  156         3835  
6              
7 156     156   892 use File::Basename ();
  156         332  
  156         2291  
8 156     156   805 use File::Spec;
  156         374  
  156         3224  
9 156     156   832 use Carp;
  156         454  
  156         9940  
10              
11 156     156   1052 use Exporter 'import';
  156         452  
  156         99184  
12             our @EXPORT_OK = qw(
13             dirname open_file path read_file_content read_glob_content
14             path_or_empty set_file_mode normalize_path escape_filename
15             );
16              
17              
18             sub path {
19 15643     15643 1 45710 my @parts = @_;
20 15643         103744 my $path = File::Spec->catfile(@parts);
21              
22 15643         39273 return normalize_path($path);
23             }
24              
25             sub path_or_empty {
26 2     2 1 2102 my @parts = @_;
27 2         6 my $path = path(@parts);
28              
29             # return empty if it doesn't exist
30 2 100       34 return -e $path ? $path : '';
31             }
32              
33 244     244 1 15580 sub dirname { File::Basename::dirname(@_) }
34              
35             sub set_file_mode {
36 83     83 1 200 my $fh = shift;
37 83         181 my $charset = 'utf-8';
38 23     23   230 binmode $fh, ":encoding($charset)";
  23         110  
  23         191  
  83         1692  
39 83         62233 return $fh;
40             }
41              
42             sub open_file {
43 65     65 1 390 my ( $mode, $filename ) = @_;
44              
45 65 100   1   3629 open my $fh, $mode, $filename
  1         9  
  1         2  
  1         4  
46             or croak "Can't open '$filename' using mode '$mode': $!";
47              
48 62         1155 return set_file_mode($fh);
49             }
50              
51             sub read_file_content {
52 34 100   34 1 19281 my $file = shift or return;
53 33         128 my $fh = open_file( '<', $file );
54              
55             return wantarray
56 31 100       155 ? read_glob_content($fh)
57             : scalar read_glob_content($fh);
58             }
59              
60             sub read_glob_content {
61 32     32 1 63 my $fh = shift;
62              
63 32         1285 my @content = <$fh>;
64 32         1083 close $fh;
65              
66 32 100       348 return wantarray ? @content : join '', @content;
67             }
68              
69             sub normalize_path {
70              
71             # this is a revised version of what is described in
72             # http://www.linuxjournal.com/content/normalizing-path-names-bash
73             # by Mitch Frazier
74 15652 50   15652 0 37350 my $path = shift or return;
75 15652         38163 my $seqregex = qr{
76             [^/]* # anything without a slash
77             /\.\.(/|\z) # that is accompanied by two dots as such
78             }x;
79              
80 15652         30494 $path =~ s{/\./}{/}g;
81 15652         63114 while ( $path =~ s{$seqregex}{} ) {}
82              
83             #see https://rt.cpan.org/Public/Bug/Display.html?id=80077
84 15652         24346 $path =~ s{^//}{/};
85 15652         66398 return $path;
86             }
87              
88             sub escape_filename {
89 51 50   51 1 2634 my $filename = shift or return;
90              
91             # based on escaping used in CHI::Driver. Our use-case is one-way,
92             # so we allow utf8 chars to be escaped, but NEVER do the inverse
93             # operation.
94 51         159 $filename =~ s/([^A-Za-z0-9_\=\-\~])/sprintf("+%02x", ord($1))/ge;
  12         88  
95 51         227 return $filename;
96             }
97              
98             1;
99              
100             __END__
101              
102             =pod
103              
104             =encoding UTF-8
105              
106             =head1 NAME
107              
108             Dancer2::FileUtils - File utility helpers
109              
110             =head1 VERSION
111              
112             version 1.0.0
113              
114             =head1 SYNOPSIS
115              
116             use Dancer2::FileUtils qw/dirname path path_or_empty/;
117              
118             # for 'path/to/file'
119             my $dir = dirname($path); # returns 'path/to'
120             my $path = path($path); # returns '/abs/path/to/file'
121             my $path = path_or_empty($path); # returns '' if file doesn't exist
122              
123              
124             use Dancer2::FileUtils qw/path read_file_content/;
125              
126             my $content = read_file_content( path( 'folder', 'folder', 'file' ) );
127             my @content = read_file_content( path( 'folder', 'folder', 'file' ) );
128              
129              
130             use Dancer2::FileUtils qw/read_glob_content set_file_mode/;
131              
132             open my $fh, '<', $file or die "$!\n";
133             set_file_mode($fh);
134             my @content = read_glob_content($fh);
135             my $content = read_glob_content($fh);
136              
137              
138             use Dancer2::FileUtils qw/open_file/;
139              
140             my $fh = open_file('<', $file) or die $message;
141              
142              
143             use Dancer2::FileUtils 'set_file_mode';
144              
145             set_file_mode($fh);
146              
147             =head1 DESCRIPTION
148              
149             Dancer2::FileUtils includes a few file related utilities that Dancer2
150             uses internally. Developers may use it instead of writing their own
151             file reading subroutines or using additional modules.
152              
153             =head1 FUNCTIONS
154              
155             =head2 my $path = path( 'folder', 'folder', 'filename');
156              
157             Provides comfortable path resolution, internally using L<File::Spec>. 'path'
158             does not verify paths, it just normalizes the path.
159              
160             =head2 my $path = path_or_empty('folder, 'folder','filename');
161              
162             Like path, but returns '' if path doesn't exist.
163              
164             =head2 dirname
165              
166             use Dancer2::FileUtils 'dirname';
167              
168             my $dir = dirname($path);
169              
170             Exposes L<File::Basename>'s I<dirname>, to allow fetching a directory name from
171             a path. On most OS, returns all but last level of file path. See
172             L<File::Basename> for details.
173              
174             =head2 set_file_mode($fh);
175              
176             use Dancer2::FileUtils 'set_file_mode';
177              
178             set_file_mode($fh);
179              
180             Applies charset setting from Dancer2's configuration. Defaults to utf-8 if no
181             charset setting.
182              
183             =head2 my $fh = open_file('<', $file) or die $message;
184              
185             use Dancer2::FileUtils 'open_file';
186             my $fh = open_file('<', $file) or die $message;
187              
188             Calls open and returns a filehandle. Takes in account the 'charset' setting
189             from Dancer2's configuration to open the file in the proper encoding (or
190             defaults to utf-8 if setting not present).
191              
192             =head2 my $content = read_file_content($file);
193              
194             use Dancer2::FileUtils 'read_file_content';
195              
196             my @content = read_file_content($file);
197             my $content = read_file_content($file);
198              
199             Returns either the content of a file (whose filename is the input), or I<undef>
200             if the file could not be opened.
201              
202             In array context it returns each line (as defined by $/) as a separate element;
203             in scalar context returns the entire contents of the file.
204              
205             =head2 my $content = read_glob_content($fh);
206              
207             use Dancer2::FileUtils 'read_glob_content';
208              
209             open my $fh, '<', $file or die "$!\n";
210             binmode $fh, ':encoding(utf-8)';
211             my @content = read_glob_content($fh);
212             my $content = read_glob_content($fh);
213              
214             Similar to I<read_file_content>, only it accepts a file handle. It is
215             assumed that the appropriate PerlIO layers are applied to the file handle.
216             Returns the content and B<closes the file handle>.
217              
218             =head2 my $norm_path=normalize_path ($path);
219              
220             =head2 my $escaped_filename = escape_filename( $filename );
221              
222             Escapes characters in a filename that may alter a path when concatenated.
223              
224             use Dancer2::FileUtils 'escape_filename';
225              
226             my $safe = escape_filename( "a/../b.txt" ); # a+2f+2e+2e+2fb+2etxt
227              
228             =head1 EXPORT
229              
230             Nothing by default. You can provide a list of subroutines to import.
231              
232             =head1 AUTHOR
233              
234             Dancer Core Developers
235              
236             =head1 COPYRIGHT AND LICENSE
237              
238             This software is copyright (c) 2023 by Alexis Sukrieh.
239              
240             This is free software; you can redistribute it and/or modify it under
241             the same terms as the Perl 5 programming language system itself.
242              
243             =cut