File Coverage

blib/lib/No/Worries/File.pm

Criterion	Covered	Total	%
statement	99	99	100.0
branch	34	44	77.2
condition	2	6	33.3
subroutine	12	12	100.0
pod	2	2	100.0
total	149	163	91.4

#+##############################################################################
#                                                                              #
# File: No/Worries/File.pm                                                     #
#                                                                              #
# Description: file handling without worries                                   #
#                                                                              #
#-##############################################################################

#
# module definition
#

package No::Worries::File;
use strict;
use warnings;
our $VERSION  = "1.5";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use No::Worries qw($_IntegerRegexp);
use No::Worries::Die qw(dief);
use No::Worries::Export qw(export_control);
use Params::Validate qw(validate :types);

#
# global variables
#

our($DefaultBufSize);

#
# open() helper
#

sub _open ($$$) {
    my($path, $mode, $opt) = @_;
    my($fh);

    return($opt->{handle}) if $opt->{handle};
    ## no critic 'InputOutput::RequireBriefOpen'
    open($fh, $mode, $path) or dief("cannot open(%s): %s", $path, $!);
    if ($opt->{binmode}) {
        binmode($fh, $opt->{binmode})
            or dief("cannot binmode(%s, %s): %s", $path, $opt->{binmode}, $!);
    } elsif ($opt->{binary}) {
        binmode($fh)
            or dief("cannot binmode(%s): %s", $path, $!);
    }
    return($fh);
}

#
# sysread() helper
#

sub _read ($$$$) {
    my($path, $fh, $data, $bufsize) = @_;
    my($done, $ref, $result);

    $done = -1;
    $ref = $data ? ref($data) : "";
    if ($ref eq "SCALAR") {
        # by reference
        ${ $data } = "";
        while ($done) {
            $done = sysread($fh, ${ $data }, $bufsize, length(${ $data }));
            dief("cannot sysread(%s): %s", $path, $!)
                unless defined($done);
        }
        $result = $data;
    } elsif ($ref eq "CODE") {
        # by code
        while ($done) {
            $result = "";
            $done = sysread($fh, $result, $bufsize);
            dief("cannot sysread(%s): %s", $path, $!)
                unless defined($done);
            $data->($result) if $done;
        }
        $result = $data->("");
    } else {
        # normal
        $result = "";
        while ($done) {
            $done = sysread($fh, $result, $bufsize, length($result));
            dief("cannot sysread(%s): %s", $path, $!)
                unless defined($done);
        }
    }
    return(\$result);
}

#
# syswrite() helper
#

sub _write ($$$$) {
    my($path, $fh, $data, $bufsize) = @_;
    my($ref, $offset, $length, $done, $chunk);

    $offset = 0;
    $ref = ref($data);
    if ($ref eq "SCALAR") {
        # by reference
        $length = length(${ $data });
        while ($length) {
            $done = syswrite($fh, ${ $data }, $bufsize, $offset);
            dief("cannot syswrite(%s): %s", $path, $!)
                unless defined($done);
            $length -= $done;
            $offset += $done;
        }
    } elsif ($ref eq "CODE") {
        # by code
        while (1) {
            $chunk = $data->();
            $length = length($chunk);
            last unless $length;
            $offset = 0;
            while ($length) {
                $done = syswrite($fh, $chunk, $bufsize, $offset);
                dief("cannot syswrite(%s): %s", $path, $!)
                    unless defined($done);
                $length -= $done;
                $offset += $done;
            }
        }
    } else {
        # normal
        $length = length($data);
        while ($length) {
            $done = syswrite($fh, $data, $bufsize, $offset);
            dief("cannot syswrite(%s): %s", $path, $!)
                unless defined($done);
            $length -= $done;
            $offset += $done;
        }
    }
}

#
# common read/write options
#

my %file_rw_options = (
    binary  => { optional => 1, type => BOOLEAN },
    binmode => { optional => 1, type => SCALAR },
    bufsize => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
    handle  => { optional => 1, type => HANDLE },
);

#
# read from a file
#

my %file_read_options = (%file_rw_options,
    data    => { optional => 1, type => SCALARREF | CODEREF },
);

sub file_read ($@) {
    my($path, %option, $fh, $result);

    $path = shift(@_);
    %option = validate(@_, \%file_read_options) if @_;
    $option{bufsize} ||= $DefaultBufSize;
    $fh = _open($path, "<", \%option);
    $result = _read($path, $fh, $option{data}, $option{bufsize});
    close($fh) or dief("cannot close(%s): %s", $path, $!);
    return(${ $result });
}

#
# write to a file
#

my %file_write_options = (%file_rw_options,
    data    => { optional => 0, type => SCALAR | SCALARREF | CODEREF },
);

sub file_write ($@) {
    my($path, %option, $fh);

    $path = shift(@_);
    %option = validate(@_, \%file_write_options);
    $option{bufsize} ||= $DefaultBufSize;
    $fh = _open($path, ">", \%option);
    _write($path, $fh, $option{data}, $option{bufsize});
    close($fh) or dief("cannot close(%s): %s", $path, $!);
}

#
# module initialization
#

$DefaultBufSize = 1_048_576; # 1MB

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    grep($exported{$_}++, map("file_$_", qw(read write)));
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__DATA__