File Coverage

blib/lib/Dancer2/FileUtils.pm

Criterion	Covered	Total	%
statement	52	52	100.0
branch	12	14	85.7
condition			n/a
subroutine	16	16	100.0
pod	8	9	88.8
total	88	91	96.7

package Dancer2::FileUtils;
# ABSTRACT: File utility helpers
$Dancer2::FileUtils::VERSION = '2.0.1';
use strict;
use warnings;

use File::Basename ();
use File::Spec;
use Carp;

use Exporter 'import';
our @EXPORT_OK = qw(
  dirname open_file path read_file_content read_glob_content
  path_or_empty set_file_mode normalize_path escape_filename
);


sub path {
    my @parts = @_;
    my $path  = File::Spec->catfile(@parts);

    return normalize_path($path);
}

sub path_or_empty {
    my @parts = @_;
    my $path  = path(@parts);

    # return empty if it doesn't exist
    return -e $path ? $path : '';
}

sub dirname { File::Basename::dirname(@_) }

sub set_file_mode {
    my $fh      = shift;
    my $charset = 'utf-8';
    binmode $fh, ":encoding($charset)";
    return $fh;
}

sub open_file {
    my ( $mode, $filename ) = @_;

    open my $fh, $mode, $filename
      or croak "Can't open '$filename' using mode '$mode': $!";

    return set_file_mode($fh);
}

sub read_file_content {
    my $file = shift or return;
    my $fh = open_file( '<', $file );

    return wantarray
      ? read_glob_content($fh)
      : scalar read_glob_content($fh);
}

sub read_glob_content {
    my $fh = shift;

    my @content = <$fh>;
    close $fh;

    return wantarray ? @content : join '', @content;
}

sub normalize_path {

    # this is a revised version of what is described in
    # http://www.linuxjournal.com/content/normalizing-path-names-bash
    # by Mitch Frazier
    my $path = shift or return;
    my $seqregex = qr{
        [^/]*       # anything without a slash
        /\.\.(/|\z) # that is accompanied by two dots as such
    }x;

    $path =~ s{/\./}{/}g;
    while ( $path =~ s{$seqregex}{} ) {}

    #see https://rt.cpan.org/Public/Bug/Display.html?id=80077
    $path =~ s{^//}{/};
    return $path;
}

sub escape_filename {
    my $filename = shift or return;

    # based on escaping used in CHI::Driver. Our use-case is one-way,
    # so we allow utf8 chars to be escaped, but NEVER do the inverse
    # operation.
    $filename =~ s/([^A-Za-z0-9_\=\-\~])/sprintf("+%02x", ord($1))/ge;
    return $filename;
}

1;

__END__