File Coverage

blib/lib/Dancer/FileUtils.pm

Criterion	Covered	Total	%
statement	69	83	83.1
branch	10	24	41.6
condition	2	2	100.0
subroutine	21	22	95.4
pod	6	9	66.6
total	108	140	77.1

package Dancer::FileUtils;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: helper providing file utilities
$Dancer::FileUtils::VERSION = '1.3521';
use strict;
use warnings;

use IO::File;

use File::Basename ();
use File::Spec;
use File::Temp qw(tempfile);

use Carp;
use Cwd 'realpath';

use Dancer::Exception qw(:all);

use base 'Exporter';
use vars '@EXPORT_OK';

@EXPORT_OK = qw(
    dirname open_file path read_file_content read_glob_content
    path_or_empty set_file_mode normalize_path
    atomic_write
);

# path should not verify paths
# just normalize
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;

    require Dancer::Config;
    my $charset = Dancer::Config::setting('charset') || 'utf-8';
    binmode $fh, ":encoding($charset)";

    return $fh;
}

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

    open my $fh, $mode, $filename
      or raise core_fileutils => "$! while opening '$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;

    # we don't want to do that as we'll encode the stuff later
    # binmode $fh;

    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
        /\.\./ # that is accompanied by two dots as such
    }x;

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

    return $path;
}

# !! currently unused
# Undo UNC special-casing catfile-voodoo on cygwin
sub _trim_UNC {
    my @args = @_;

    # if we're using cygwin
    if ( $^O eq 'cygwin' ) {
        # no @args, no problem
        @args or return;

        my ( $slashes, $part, @parts) = ( 0, undef, @args );

        # start pulling part from @parts
        while ( defined ( $part = shift @parts ) ) {
            last if $part;
            $slashes++;
        }

        # count slashes in $part
        $slashes += ( $part =~ s/^[\/\\]+// );

        if ( $slashes == 2 ) {
            return ( '/' . $part, @parts );
        } else {
            my $slashstr = '';
            $slashstr .= '/' for ( 1 .. $slashes );

            return ( $slashstr . $part, @parts );
        }
    }

    return @args;
}

sub atomic_write {
    my ($path, $file, $data) = @_;
    my ($fh, $filename) = tempfile("tmpXXXXXXXXX", DIR => $path);
    set_file_mode($fh);
    print $fh $data;
    close $fh or die "Can't close '$file': $!\n";
    rename($filename, $file) or die "Can't move '$filename' to '$file'";
}

1;

__END__