File Coverage

blib/script/narada-setup-qmail

Criterion	Covered	Total	%
statement	101	102	99.0
branch	30	44	68.1
condition	15	21	71.4
subroutine	19	19	100.0
pod			n/a
total	165	186	88.7

#!/usr/bin/env perl
use 5.010001;
use warnings;
use strict;
use utf8;

our $VERSION = 'v2.3.7';

use FindBin;
use lib "$FindBin::Bin/../lib/perl5";
use Narada;
use Narada::Config qw( get_config set_config );
use File::Temp qw( tempfile );
use Cwd qw( cwd );
use Path::Tiny;


main(@ARGV) if !caller;


sub err { die "narada-setup-qmail: @_\n" }

sub main {
    die "Usage: narada-setup-qmail [--clean|--lock]\n"
        if (@_ >  1)
        || (@_ == 1 && $_[0] ne '--clean' && $_[0] ne '--lock');
    my $clean = @_ && $_[0] eq '--clean';
    my $lock  = @_ && $_[0] eq '--lock';

    if ($clean) {
        path('var/use/qmail')->remove;
        for my $file (ls_qmail()) {
            unlink $file                        or err "unlink($file): $!";
        }
        unlink '.lock.qmail';
    }
    else {
        if (Narada::detect() eq 'narada') {
            path('var/use/qmail')->touch;
        }
        if ($lock) {
            lock_qmail();
        }
        else {
            setup_qmail();
        }
    }

    return;
}

sub lock_qmail {
    my $cwd = cwd();
    my $lock = "$cwd/.lock.qmail";
    replacefile($lock, '|false');

    my $temp = 'tmp/.qmail.symlink';
    unlink $temp;
    for my $qmail (ls_qmail()) {
        symlink $lock, $temp                    or err "symlink($lock,$temp): $!";
        rename $temp, $qmail                    or err "rename($temp,$qmail): $!";
    }

    return;
}

sub setup_qmail {
    my $cwd = cwd();
    my $lock = "$cwd/.lock.qmail";
    my $temp = 'tmp/.qmail.symlink';
    unlink $temp;

    for my $file (ls('config/qmail')) {
        # read from config/qmail/
        my $data = get_config("qmail/$file");
        $data =~ s/^[|]/|cd \Q$cwd\E || exit(100); /gmxs;
        # write to var/qmail/
        my $path = "$cwd/var/qmail/$file";
        replacefile($path, $data);
        # symlink at ~/.qmail-
        my $qmail = "$ENV{HOME}/.qmail-$file";
        if (! -e $qmail) {
            symlink $path, $qmail               or err "symlink($path,$qmail): $!";
        }
        elsif (-l $qmail && _readlink($qmail) eq $lock) {
            symlink $path, $temp                or err "symlink($path,$temp): $!";
            rename $temp, $qmail                or err "rename($temp,$qmail): $!";
        }
        elsif (! (-l $qmail && _readlink($qmail) eq $path)) {
            err "Conflict detected on $qmail";
        }
    }

    # cleanup
    for my $file (grep {! -f "config/qmail/$_"} ls('var/qmail')) {
        unlink "var/qmail/$file"                or err "unlink(var/qmail/$file): $!";
    }
    unlink $lock;
    for my $file (grep {! -f} ls_qmail()) {
        unlink $file                            or err "unlink($file): $!";
    }

    return;
}

sub ls_qmail {
    my $cwd = cwd();
    my @files =
        grep {-l && _readlink($_) =~ m{\A\Q$cwd\E/}xms}
        map {"$ENV{HOME}/$_"}
        grep { m/\A[.]qmail-/xms }
        ls($ENV{HOME});
    return @files;
}

sub replacefile {
    my ($file, $data) = @_;
    (my $dir = $file) =~ s{/[^/]+\z}{}xms;
    my ($fh, $temp) = tempfile(DIR => $dir);
    print {$fh} $data;
    close $fh                                   or err "close($temp): $!";
    rename $temp, $file                         or err "rename($temp,$file): $!";
    return;
}

sub ls {
    my ($dir) = @_;
    opendir my $d, $dir                         or err "opendir($dir): $!";
    my @files = grep { $_ ne q{.} && $_ ne q{..} } readdir $d;
    closedir $d                                 or err "closedir($dir): $!";
    return @files;
}

sub _readlink {
    my ($link) = @_;
    my $path = readlink $link                   or err "readlink($link): $!";
    return $path;
}


1; # Magic true value required at end of module
__END__