File Coverage

blib/lib/File/Create/Layout.pm

Criterion	Covered	Total	%
statement	129	147	87.7
branch	74	104	71.1
condition	3	8	37.5
subroutine	8	10	80.0
pod	3	3	100.0
total	217	272	79.7

package File::Create::Layout;

our $DATE = '2019-04-16'; # DATE
our $VERSION = '0.060'; # VERSION

use 5.010001;
use strict;
use warnings;
use Log::ger;

use File::chdir;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
                       create_files_using_layout
               );

our %SPEC;

my %arg_layout = (
    layout => {
        summary => 'Layout',
        description => <<'_',

See the module documentation for the format/specification of layout.

_
        schema => 'str*',
        req => 1,
        pos => 0,
    },
);

sub _decode_json {
    state $json = do {
        require JSON::MaybeXS;
        JSON::MaybeXS->new->allow_nonref;
    };
    $json->decode(shift);
}

sub _parse_layout {
    my $layout = shift;

    my @indents;
    my @res;
    my $linum = 0;
    my $prev_is_dir = 0;
    for my $line (split /^/, $layout) {
        chomp $line;
        my $orig_line = $line;

        $linum++;
        next if $line =~ /\A\s*\z/;
        next if $line =~ /\A\s*#/;

        $line =~ s/\A(\s*)//;
        my $cur_indent = $1;
        die "(layout):$linum: Tabs are not allowed: $orig_line"
            if $cur_indent =~ /\t/;

        $cur_indent = length($cur_indent);

        if (!@indents) {
            push @indents, $cur_indent;
        }

        if ($cur_indent > $indents[-1]) {
            # indent is deeper than previous spec-line, we require that the
            # previous spec-line is directory
            die "(layout):$linum: More indented than previous spec-line, but ".
                "previous spec-line is not a directory: $orig_line"
                unless $prev_is_dir;
            push @indents, $cur_indent;
        } elsif ($cur_indent < $indents[-1]) {
            # indent is shallower than previous spec-line, find previous level
            my $found = 0;
            for my $i (reverse 0..$#indents) {
                if ($cur_indent == $indents[$i]) {
                    $found++;
                    splice @indents, $i+1;
                    last;
                }
            }
            die "(layout):$linum: Invalid indent, must return to one of ".
                "previous levels' indent: $orig_line" unless $found;
        }

        # parse filename
        my $name;
        if ($line =~ /\A"/) {
            $line =~ s#\A(".*?(?
                or die "(layout):$linum: Invalid quoted filename: $orig_line";
            $name = $1;
            eval { $name = _decode_json($name) };
            die "(layout):$linum: Invalid JSON string in filename: $@: $1"
                if $@;
        } else {
            $line =~ s!\A([^\s\(/]*)!!;
            $name = $1;
        }
        die "(layout):$linum: Filename cannot be empty: $orig_line"
            unless length($name);
        die "(layout):$linum: Filename cannot contain slashes: $orig_line"
            if $name =~ m!/!;
        die "(layout):$linum: Filename cannot be . or ..: $orig_line"
            if $name =~ m!\A\.\.?\z!;

        my $is_dir;
        if ($line =~ s!\A/!!) {
            $is_dir = 1;
        } else {
            $is_dir = 0;
        }

        my ($orig_perm, $perm, $user, $group);
        if ($line =~ /\A\(/) {
            $line =~ s/\A\((?:([^,]*),([^,]*),)?([0-7]{3,4})\)//
                or die "(layout):$linum: Invalid syntax in permission/owner: $orig_line";
            $user  = $1;
            $group = $2;
            $orig_perm = $3;
            $perm  = oct($3);
        }

        my $sym_target;
        if ($line =~ s/\s+->\s*//) {
            die "(layout):$linum: Symlink cannot be a directory: $orig_line"
                if $is_dir;
            # parse symlink target
            if ($line =~ /\A"/) {
                $line =~ s#\A(".*?(?
                    or die "(layout):$linum: Invalid quoted symlink target: $orig_line";
                $sym_target = $1;
                eval { $sym_target = _decode_json($sym_target) };
                die "(layout):$linum: Invalid JSON string in symlink target: $@: $1"
                    if $@;
            } else {
                $line =~ s!\A([^\s]*)!!;
                $sym_target = $1;
            }
            die "(layout):$linum: Symlink target cannot be empty: $orig_line"
                unless length($sym_target);
        }

        my $extras;
        if ($line =~ s/\s+(\S.*)//) {
            $extras = $1;
            eval { $extras = _decode_json("{$extras}") };
            die "(layout):$linum: Invalid unquoted JSON hash in extras: $@: $extras"
                if $@;
            if (defined $extras->{content}) {
                die "(layout):$linum: Directory must not have 'content': $@: $orig_line"
                    if $is_dir;
            }
        }

        push @res, {
            name       => $name,
            is_dir     => $is_dir,
            is_symlink => defined($sym_target) ? 1:0,
            (symlink_target => $sym_target) x !!(defined $sym_target),
            level      => $#indents >= 0 ? $#indents : 0,
            _linum     => $linum,
            perm       => $perm,
            perm_octal => $orig_perm,
            user       => $user,
            group      => $group,
            (content    => $extras->{content}) x !!(defined $extras->{content}),
        };

        $prev_is_dir = $is_dir;
    }

    \@res;
}

$SPEC{create_files_using_layout} = {
    v => 1.1,
    summary => 'Create files/directories according to a layout',
    description => <<'_',

This routine can be used to quickly create several files/directories according
to a layout which you specify. The layout uses a few simple rules and common
conventions usually found in Linux/Unix environment.

You can use this routine e.g. in a test script.

_
    args => {
        %arg_layout,
        prefix => {
            summary => 'Root directory to create the files/directories in',
            description => <<'_',

Directory must already exist.

If unspecified, will simply create starting from current directory.

_
            schema => 'str*',
        },
    },
};
sub create_files_using_layout {
    require File::chown;

    my %args = @_;

    my $parse_res;
    eval { $parse_res = _parse_layout($args{layout}) };
    return [400, "Syntax error in layout: $@"] if $@;

    my $prefix = $args{prefix};
    local $CWD = $prefix // $CWD;
    $prefix //= ".";

    my $prev_level;
    my @dirs;
    for my $e (@$parse_res) {
        my $p = $prefix . join("", map {"/$_"} @dirs);

        if (defined $prev_level) {
            if ($e->{level} > $prev_level) {
                log_trace("chdir %s ...", $dirs[-1]);
                eval { $CWD = $dirs[-1] };
                return [500, "Can't chdir to $p/$e->{name}: $! (cwd=$CWD)"] if $@;
            } elsif ($e->{level} < $prev_level) {
                my $dir = join("/", (("..") x ($prev_level - $e->{level})));
                splice @dirs, $e->{level};
                $p = $prefix . join("", map {"/$_"} @dirs);
                log_trace("chdir back %s ...", $dir);
                eval { $CWD = $dir };
                return [500, "Can't chdir back to $dir: $! (cwd=$CWD)"]
                    if $@;
            }
        }

        log_trace("Creating %s/%s%s ...",
                     $p, $e->{name}, $e->{is_dir} ? "/":"");
        if ($e->{is_dir}) {
            do {
                if (defined $e->{perm}) {
                    mkdir($e->{name}, $e->{perm});
                } else {
                    mkdir($e->{name});
                }
            } or return [500, "Can't create directory $p/$e->{name}: $!"];
            $dirs[$e->{level}] = $e->{name};
        } elsif ($e->{is_symlink}) {
            symlink($e->{symlink_target}, $e->{name})
                or return [500, "Can't create symlink $p/$e->{name} -> ".
                           "$e->{symlink_target}: $!"];
        } else {
            open my($fh), ">", $e->{name}
                or return [500, "Can't create file $p/$e->{name}: $!"];
            if (defined $e->{content}) {
                print $fh $e->{content}
                    or return [500, "Can't write content to file ".
                               "$p/$e->{name}: $!"];
            }
            if (defined $e->{perm}) {
                chmod($e->{perm}, $e->{name})
                    or return [500, "Can't chmod file $p/$e->{name}: $!"];
            }
        }

        if (defined($e->{user}) || defined($e->{group})) {
            my %opts;
            $opts{deref} = 0 if $e->{is_symlink};
            File::chown::chown(\%opts, $e->{user}, $e->{group}, $e->{name})
                  or return [500, "Can't chown file $p/$e->{name}: $!"];
        }

        $prev_level = $e->{level};
    }

    [200, "OK"];
}

$SPEC{check_layout} = {
    v => 1.1,
    summary => 'Check whether layout has syntax errors',
    args => {
        %arg_layout,
    },
};
sub check_layout {
    my %args = @_;

    eval { _parse_layout($args{layout}) };
    my $err = $@;
    [200, "OK", $err ? 0:1, {'func.error' => $err}];
}

$SPEC{parse_layout} = {
    v => 1.1,
    summary => 'Parse layout string into a data structure '.
        'suitable for processing',
    args => {
        %arg_layout,
    },
};
sub parse_layout {
    my %args = @_;

    my $res;
    eval { $res = _parse_layout($args{layout}) };
    return [400, "Layout has error(s): $@"] if $@;
    [200, "OK", $res];
}

1;
# ABSTRACT: Quickly create files/directories according to a layout

__END__