dewi.in

#!@@PERL5@@

# Copyright (c) 2010-2018
# Frank Terbeck <ft@bewatermyfriend.org>, All rights reserved.
# Terms for redistribution and use can be found in `LICENCE'.

package Dewi::Exceptions::EarlyExit;

sub new {
    my ($class) = @_;
    $self = { config => { do_deploy => 0,
                          be_silent => 0,
                          output_to_stderr => 1,
                          exit => undef },
              output => [ ] };
    bless $self, $class;
    return $self;
}

sub add_config {
    my ($self, $hr) = @_;
    $self->{config} = { %{ $self->{config} }, %{ $hr } };
    return $self->{config};
}

sub add_output {
    my ($self, $output) = @_;
    if (ref $output eq q{ARRAY}) {
        push @{ $self->{output} }, @{ $output };
    } else {
        push @{ $self->{output} }, $output;
    }
    return $self->{output};
}

sub print_output {
    my ($self) = @_;
    my $printer = sub { return $self->print_to_stderr() ? warn @_ : print @_ };
    foreach my $line (@{ $self->{output} }) {
        $printer->($line, qq{\n});
    }
    return $#{ $self->{output} };
}

sub be_silent {
    my ($self) = @_;
    return $self->{config}->{be_silent};
}

sub do_deploy {
    my ($self) = @_;
    return $self->{config}->{do_deploy};
}

sub do_exit {
    my ($self) = @_;
    return $self->{config}->{exit};
}

sub print_to_stderr {
    my ($self) = @_;
    return $self->{config}->{output_to_stderr};
}

package Dewi::Storage::WithFallback;

# Basic key/value storage with fallback support.

sub new {
    my ($class, $self) = @_;
    $self = {} unless (defined $self);
    bless $self, $class;
    return $self;
}

# Gets a $key from the internal storage. If it is not defined in this
# instance's internal storage, try the fallback instance instead. Returns undef
# in case no defined value could be found for the $key in any of the queried
# instances.
sub get {
    my ($self, $key) = @_;
    my $result = $self->{getter}->($self, $key);
    return $result if (defined $result);
    return if (not defined $self->{fallback});
    return $self->{fallback}->{getter}->($self->{fallback}, $key);
}

# Set a $key to a $value in an instances internal data store.
sub set {
    my ($self, $key, $value) = @_;
    return $self->{setter}->($self, $key, $value);
}

# Set the fallback instance to another WithFallback class instance.
sub set_fallback {
    my ($self, $fb) = @_;
    $self->{fallback} = $fb;
}

package Dewi::Storage::Options;
use parent -norequire, "Dewi::Storage::WithFallback";

# This is a fairly simple key/value store with support for getting data from
# other Dewi::Storage::WithFallback storages. This one also has support for
# interpreting values as boolean data when retrieving data from the storage.
#
# This data structure is used for implementing options and user options, of
# which there are global and package-local variants of both.

# This class uses $self->{data} as its internal storage. It is a hash ref to
# arbitrary types of values.

sub setopt {
    my ($self, $key, $value) = @_;
    $self->{data}->{$key} = $value;
    return $value;
}

sub getopt {
    my ($self, $key) = @_;
    return $self->{data}->{$key};
}

# The following three sub-routines implement the interpretation of Perl scalar
# values as boolean values.

sub is_bool_false {
    my ($value) = @_;

    return 1 if (!defined $value
                 || $value eq 'no'
                 || $value eq 'no_thanks'
                 || $value eq 'off'
                 || $value eq 'false'
                 || $value eq '0');
    return 0;
}

sub is_bool_true {
    my ($value) = @_;

    return 0 if (!defined $value);
    return 1 if ($value eq 'yes'
                 || $value eq 'yes_please'
                 || $value eq 'on'
                 || $value eq 'true'
                 || $value eq '1');
    return 0;
}

sub getopt_bool {
    my ($self, $key) = @_;
    my $value;

    $value = $self->get($key);
    return 0 if (is_bool_false($value));
    return 1 if (is_bool_true($value));

    warn "Unknown value for boolean option \"$key\" ($value).";
    warn " Assuming false.\n";
    return 0;
}

sub new {
    my ($class, $data) = @_;
    my $self = $class->SUPER::new($data);
    $self->{data} = {};
    $self->{getter} = \&getopt;
    $self->{setter} = \&setopt;
    return $self;
}

package Dewi::Storage::Hooks;
use parent -norequire, "Dewi::Storage::WithFallback";

# This is a second kind of key-value store. But instead of accepting arbitrary
# Perl data as values, it maintains a list of code refs, to be used as hooks.
# The key to the list of values is the name of the hook to be run. This is
# obviously used for implementing hooks in dewi. It has methods like push,
# add, remove_first, remove_last and remove_all to manipulate the list of
# hooks. There are also get and set methods that modify the list of hooks
# directly.
#
# As with options, hooks have global and package-local variants, where the
# package-local variant overrides the list from the global variant.

# Push a new hook to the end of the current list.

sub push {
    my ($self, $key, $value) = @_;
    my $list = $self->safe_gethooks($key);
    push @{ $list }, $value;
    $self->sethooks($key, $list);
    return $list;
}

# Add a new hook to the start of the current list.

sub add {
    my ($self, $key, $value) = @_;
    my $list = $self->safe_gethooks($key);
    unshift @{ $list }, $value;
    $self->sethooks($key, $list);
    return $list;
}

# Get a list of hooks, possibly from fallback instances. If none were found,
# return an empty array ref.

sub safe_gethooks {
    my ($self, $key) = @_;
    my $list = $self->get($key);
    return $list if (defined $list);
    return [];
}

# Set the data-set for a $key to an empty array ref. If $key is not specified,
# clear the data-sets of *all* keys of *THIS* instance. This method does not
# decent into fallback instances.

sub clear {
    my ($self, $key) = @_;
    if (defined $key) {
        $self->sethooks($key, []);
        return $self->{data}->{$key};
    }
    foreach my $name (keys %{ $self->{data} }) {
        $self->clear($name);
    }
    return $self->{data};
}

# Entirely delete the data-set for $key. If $key is not specified, the entire
# internal storage of *THIS* instance is set to an empty hash ref.

sub delete {
    my ($self, $key) = @_;
    if (defined $key) {
        delete $self->{data}->{$key};
    } else {
        $self->{data} = {};
    }
    return $self->{data};
}

sub gethooks {
    my ($self, $key) = @_;
    return $self->{data}->{$key};
}

sub sethooks {
    my ($self, $key, $value) = @_;
    $self->{data}->{$key} = $value;
    return $value;
}

sub new {
    my ($class, $data) = @_;
    my $self = $class->SUPER::new($data);
    $self->{data} = undef;
    $self->{getter} = \&gethooks;
    $self->{setter} = \&sethooks;
    return $self;
}

package DewiFile;

use strict;
use warnings qw(all);
use English '-no_match_vars';
use File::Find;
use File::Glob qw{ bsd_glob };
use File::Spec;
use File::Basename;
use Getopt::Long;
use Cwd;
use Scalar::Util qw{ blessed };

my $reg_calls = 0;
our (%DEWI, $local_options, $user_settings, $local_hooks);

# output
sub verbose {
    DewiInternal::verbose(@_);
    return 1;
}

sub debug {
    DewiInternal::debug(@_);
    return 1;
}

# option handling
sub set_opt {
    my ($key, $value) = @_;
    return DewiInternal::set_opt($key, $value);
}

sub set_opt_default {
    my ($key, $value) = @_;
    return DewiInternal::set_opt_default($key, $value);
}

sub get_opt {
    my ($key) = @_;
    return DewiInternal::get_opt($key);
}

sub get_opt_default {
    my ($key) = @_;
    return DewiInternal::get_opt_default($key);
}

sub get_opt_bool {
    my ($key) = @_;
    return DewiInternal::get_opt_bool($key);
}

sub get_opt_bool_default {
    my ($key) = @_;
    return DewiInternal::get_opt_bool_default($key);
}


# user definable settings
sub user_set {
    my ($key, $value) = @_;
    return DewiInternal::user_set($key, $value);
}

sub user_set_default {
    my ($key, $value) = @_;
    return DewiInternal::user_set_default($key, $value);
}

sub user_get {
    my ($key) = @_;
    return DewiInternal::user_get($key);
}

sub user_get_default {
    my ($key) = @_;
    return DewiInternal::user_get_default($key);
}

sub user_get_bool {
    my ($key) = @_;
    return DewiInternal::user_get_bool($key);
}

sub user_get_bool_default {
    my ($key) = @_;
    return DewiInternal::user_get_bool_default($key);
}

# helpers
# hooks
sub __add_hook {
    my ($store, $h) = @_;
    my ($ev);

    goto ERROR if (ref($h) ne 'HASH');
    $h->{type} = 'perl' if (!defined $h->{type});
    goto ERROR if (!defined $h->{code} || !defined $h->{event});
    if ($h->{type} ne 'perl' && $h->{type} ne 'shell-inline'
            && $h->{type} ne 'shell-file')
    {
        print "The type parameter needs to be one of these:\n";
        print "  - perl\n";
        print "  - shell-file\n";
        print "  - shell-inline\n";
        print "\n";
        goto ERROR;
    }
    if ($h->{type} eq 'perl' && ref($h->{code}) ne 'CODE') {
        print "add_hook(): When `type' is \"perl\","
            . " `code' needs to be a coderef.\n\n";
        goto ERROR;
    }
    if ($h->{type} eq 'shell-file' && !-f ref($h->{code})) {
        print "add_hook(): When `type' is \"shell-file\","
            . " `code' needs to be an existing file.\n\n";
        goto ERROR;
    }
    $ev = $h->{event};
    delete($h->{event});
    DewiInternal::register_hook($ev, $h);
    return 1;

ERROR:
    print "usage: add_hook(<hash-ref>);\n";
    print "See dewifile(5) for details.\n";
    exit 1;
}

sub add_hook {
    my ($h) = @_;
    my $store = (defined $local_hooks) ? $local_hooks : $DewiInternal::hooks;
    return __add_hook($store, $h);
}

sub add_hook_default {
    my ($h) = @_;
    return __add_hook($DewiInternal::hooks, $h);
}

sub clear_hook {
    my ($hook) = @_;
    my $store = (defined $local_hooks) ? $local_hooks : $DewiInternal::hooks;
    return $store->clear($hook);
}

sub clear_hook_default {
    my ($hook) = @_;
    return $DewiInternal::hooks->clear($hook);
}

sub delete_hook {
    my ($hook) = @_;
    my $store = (defined $local_hooks) ? $local_hooks : $DewiInternal::hooks;
    return $store->delete($hook);
}

sub delete_hook_default {
    my ($hook) = @_;
    return $DewiInternal::hooks->delete($hook);
}

# predefined hook code
sub nuke_dead_links_register {
    my ($dir, $glob) = @_;

    if (!defined $dir || !defined $glob) {
        die "Usage: nuke_dead_links_register('<dir>', '<glob>');\n";
    }
    my $store = (defined $local_options) ? $local_options : $DewiInternal::options;
    my $cfg = $store->get(q{nuke-dead-links-cfg});
    $cfg = {} unless (defined $cfg);
    $cfg->{$dir} = $glob;
    $store->set(q{nuke-dead-links-cfg}, $cfg);
    $store->set(q{nuke-dead-links-verbose}, 1)
        unless (defined $store->get(q{nuke-dead-links-verbose}));
    return 1;
}

sub nuke_dead_links {
    my $odir = cwd();
    my $store = (defined $local_options) ? $local_options : $DewiInternal::options;
    my $cfg = $store->get(q{nuke-dead-links-cfg});
    if (!(defined $cfg && (ref $cfg eq q{HASH}))) {
        print qq{nuke_dead_links(): Missing configuration!\n};
        return 0;
    }
    DIR: foreach my $dir (sort keys %{ $cfg }) {
        my $key = $dir;
        $dir =~ s!^~!$ENV{HOME}!;
        $dir =~ s/\/+$//;
        chdir($dir) or do { print "Couldn't change to $dir: $ERRNO\n";
                            next DIR; };
        print "Nuking dead symbolic links in $dir/...\n"
            if ($store->getopt_bool(q{nuke-dead-links-verbose}));
        my @dls = grep { -l && ! -e } bsd_glob($cfg->{$key});
        foreach my $dl (sort @dls) {
            print "nuke_dead_links(): Removing dead link: $dl\n";
            unlink $dl || print "    Failed to remove dead link: $ERRNO\n";
        }
        chdir($odir) or die "Couldn't change to $odir: $ERRNO\n";
    }
    return 1;
}

# request empty directories
sub deploy_directory {
    if ($#_ != 0) {
        die "usage: deploy_directory('directory_name');\n";
    }
    my ($dir) = @_;

    my $new = {};
    $new->{destination} = DewiInternal::expand_dir($dir);
    $new->{deploydir} = 'yes';
    debug("deploy_directory(): \"" . $new->{destination} . "\"\n");
    push @DewiInternal::regfiles, $new;
}

# predefined `glob' code
sub regularfiles {
    my ($glob) = @_;

    return grep { -f } bsd_glob($glob);
}

sub recursivefiles {
    my ($data) = @_;
    my (@files, $regex);

    if (ref($data) ne 'HASH') {
        my $save = $data;
        $data = {};
        $data->{basedir} = $save;
    }
    $data->{basedir} = '.' if (!defined $data->{basedir});
    $data->{regex} = '.' if (!defined $data->{regex});

    $regex = qr{$data->{regex}};
    my $findcb = sub {
        return if !-f;
        return if (!m/$regex/);
        push @files, $File::Find::name;
    };
    find($findcb, $data->{basedir});
    return @files;
}

# predefined `post-glob' code
sub remove_tilde {
    # throw away stuff that matches "*~"
    my (@ret);

    foreach my $file (@_) {
        if ($file !~ m/~$/) {
            push @ret, $file
        } else {
            debug("Weeding out backup file: `$file'\n");
        }
    }

    return @ret;
}

sub remove_hashes {
    # throw away stuff that matches "#*#"
    my (@ret);

    foreach my $file (@_) {
        my $name = basename($file);
        if ($name !~ m/^#.+#$/) {
            push @ret, $file
        } else {
            debug("Weeding out temporary file: `$file'\n");
        }
    }

    return @ret;
}

# predefined `transform' code
sub notransform {
    return $_[0];
}

sub makedotfile {
    return '.' . $_[0];
}

# predefined `destination' code
sub recursive_dirname {
    my ($prefix, $data) = @_;
    return expand_path(merge_path($prefix, $data->{srcdir}));
}

# predefined `filter' code
sub print_filter {
    my ($line) = @_;
    return $line;
}

sub simple_filter_init {
    my ($file) = @_;
    unless (defined $file) {
        warn qq{Usage: simple_filter_init('<file>');\n};
        return 0;
    }
    $file = DewiInternal::expand_dir($file);
    my $store = (defined $local_options) ? $local_options : $DewiInternal::options;
    my $cfg = $store->get(q{simple-filter-cfg});
    $cfg = {} unless (defined $cfg);
    open my $in, q{<}, $file or do {
        warn "Could not open file ($file): $ERRNO\n";
        return 0;
    };
    while (my $line = <$in>) {
        my ($tag, $repl);
        chomp $line;
        next if ($line =~ m/^\s*#/ || $line =~ m/^\s*$/);
        if (($tag, $repl) = $line =~ m/^([^:]+):(.*)$/) {
            $cfg->{$tag} = $repl;
        } else {
            warn "Unknown line in filter file: \"$line\"\n";
            return 0;
        }
    }
    close $in;
    $store->set(q{simple-filter-cfg}, $cfg);
    return 1;
}

sub simple_filter {
    my ($line) = @_;
    my $store = (defined $local_options) ? $local_options : $DewiInternal::options;
    my $cfg = $store->get(q{simple-filter-cfg});
    return $line unless (defined $cfg && ref $cfg eq q{HASH});
    foreach my $tag (sort keys %{ $cfg }) {
        my $repl = $cfg->{$tag};
        $line =~ s/$tag/$repl/g;
    }
    return $line;
}

# path name helpers
sub merge_path {
    if ($#_ != 1) {
        die "Usage: merge_path(<part_one>, <part_two>);\n";
    }
    DewiInternal::merge_name(@_);
}

sub expand_path {
    if ($#_ != 0) {
        die "Usage: merge_path(<directory>);\n";
    }
    DewiInternal::expand_dir(@_);
}

# Miscellaneous helpers
sub find_cmd {
    my ($cmd, $args) = @_;
    my $path;
    if (defined $args->{path}) {
        $path = $args->{path};
    } else {
        $path = [ split /:/, $ENV{PATH} ];
    }
    if (defined $args->{more}) {
        push @{ $path }, @{ $args->{more} };
    }
    foreach my $e (@{ $path }) {
        my $rc = DewiInternal::expand_dir($e) . "/$cmd";
        return $rc if (-f $rc);
    }
    return $args->{fallback} if (defined $args->{fallback});
    return;
}

# The `register()' subroutine
sub __register_defaults {
    # This sets default values for the different meaningful keys and
    # also does some error-checking on values where it makes sense.
    my ($h) = @_;

    if (!defined $h->{glob}) {
        die "Cannot call register() without `glob' argument.\n";
    }
    if (ref($h->{glob}) eq 'CODE' && !defined &{ $h->{glob} }) {
        die
        "register(): Unknown coderef in `glob'.\n".
        "                        Call number $reg_calls.\n";
    }

    if (!defined $h->{destination}) {
        $h->{destination} = '~/';
        debug("register(): Setting default `destination': ~/\n");
    }

    if (!defined $h->{method}) {
        $h->{method} = 'copy';
        debug("register(): Setting default `method': copy\n");
    }
    if (!DewiInternal::method_exists($h->{method})) {
        die
        "register(): Unknown `method' parameter: \"" . $h->{method} . "\"\n".
        "                        Call number $reg_calls.\n";
    }

    if (!defined $h->{transform}) {
        $h->{transform} = \&notransform;
        debug("register(): Setting default `transform': `notransform'\n");
    }

    if (!defined &{ $h->{transform} }) {
        die
        "register(): Unknown coderef in `transform'.\n".
        "                        Call number $reg_calls.\n";
    }

    if (defined $h->{post_glob} && !defined &{ $h->{post_glob} }) {
        die
        "register(): Unknown coderef in `post_glob'.\n".
        "                        Call number $reg_calls.\n";
    }

    if (!defined $h->{globarg}) {
        $h->{globarg} = '';
        debug("register(): Setting default `globarg': (empty string)\n");
    }

    if ($h->{method} eq 'template') {
        if (!defined $h->{options}) {
            debug("register(): Setting default `options' for Template.\n");
            $h->{options} = { };
        }
        if (!defined $h->{data}) {
            debug("register(): Setting default `data' for Template.\n");
            $h->{data} = { };
        }
    }

    if ($h->{method} eq 'filtered') {
        if (!defined $h->{filtertype}) {
            debug("register(): Setting default `filtertype': perl\n");
            $h->{filtertype} = 'perl';
        }
        if (!defined $h->{filter}) {
            $h->{filtertype} = 'perl';
            debug("register(): Setting default `filter': \&print_filter\n");
            $h->{filter} = \&print_filter;
        }
        if ($h->{filtertype} eq 'perl' && !defined &{ $h->{filter} }) {
            die "register(): perl filter: Unknown coderef.\n".
                "                        Call number $reg_calls.\n";
        }
        if ($h->{filtertype} eq 'shell-file' && !-e $h->{filter}) {
            die "register(): shell-file filter: File does not exist `" .
                $h->{filter} . "'.\n".
                "                        Call number $reg_calls.\n";
        }
    } elsif (defined $h->{concatenate}) {
        die "register(): `concatenate' only allowed with method `filtered'.\n"
          . "            Call number $reg_calls.\n";
    }

    if (defined $h->{intercat}) {
        my $ic = $h->{intercat};

        if (!defined $ic->{type} || $ic->{type} eq 'perl') {
            foreach my $cb (qw{firstpre firstpost
                               lastpre lastpost
                               otherpre otherpost})
            {
                if ((!defined $ic->{$cb.'type'} || $ic->{$cb.'type'} eq 'perl')
                    && defined $ic->{$cb} && !defined &{ $ic->{$cb} }) {
                    die "register(): concatenate callback `$cb' does not point"
                        . "                        to a valid Perl subroutine."
                        . " Call number $reg_calls.\n";
                }
            }
        }
    }

    return 1;
}

sub __register {
    my ($h) = @_;
    my (@files);

    if (ref($h->{glob}) eq 'CODE') {
        @files = DewiInternal::run_coderef(
            q{globbing callback}, $h->{glob}, $h->{globarg});
    } elsif (ref($h->{glob}) eq 'ARRAY') {
        foreach my $entry (@{ $h->{glob} }) {
            my @f = bsd_glob($entry);
            if (defined $h->{post_glob_single}
                && ref $h->{post_glob_single} eq 'CODE') {
                @f = DewiInternal::run_coderef(
                    q{post_glob_single callback}, $h->{post_glob_single}, @f);
            }
            push @files, @f;
        }
    } else {
        @files = bsd_glob($h->{glob});
    }
    if (defined $h->{post_glob} && ref $h->{post_glob} eq 'CODE') {
        @files = DewiInternal::run_coderef(
            q{post_glob callback}, $h->{post_glob}, @files);
    }

    if (ref($h->{destination}) ne 'CODE') {
        $h->{destination} = DewiInternal::expand_dir($h->{destination});
    }
    foreach my $path (@files) {
        my $new = {};
        my ($volume,$directories,$file) = File::Spec->splitpath( $path );

        $new->{path} = $path;
        $directories =~ s/\/+$//;
        $new->{srcdir} = $directories;
        $new->{name} = $file;
        if (defined $h->{concatenate}) {
            $new->{concatenate} = DewiInternal::run_coderef(
                q{transform callback}, $h->{transform}, $h->{concatenate});
            $new->{transformed} = $new->{concatenate};
        } else {
            $new->{transformed} = DewiInternal::run_coderef(
                q{transform callback}, $h->{transform}, $file);
        }

        if (ref($h->{destination}) eq 'CODE') {
            my %copy = %{ $new };
            $new->{destination} = DewiInternal::run_coderef(
                q{destination callback}, $h->{destination}, $h->{destarg}, \%copy );
        } else {
            $new->{destination} = $h->{destination};
        }

        $new->{method} = $h->{method};
        if ($new->{method} eq 'template') {
            $new->{options} = $h->{options};
            $new->{data} = $h->{data};
        }
        $new->{filter} = $h->{filter};
        $new->{filtertype} = $h->{filtertype};
        $new->{intercat} = $h->{intercat};
        $new->{mergedname} =
            DewiInternal::merge_name($new->{destination}, $new->{transformed});

        debug(
            "register(): \""      . $new->{path}        . "\"\n" .
            "           Name: \"" . $new->{name}        . "\"\n");
        debug(
            "    Concatenate: \"" . $new->{concatenate} . "\"\n")
                 if (defined $new->{concatenate});
        debug(
            "    Transformed: \"" . $new->{transformed} . "\"\n" .
            "         Source: \"" . $new->{srcdir}      . "\"\n" .
            "    Destination: \"" . $new->{destination} . "\"\n" .
            "    Merged-Name: \"" . $new->{mergedname}  . "\"\n" .
            "         Method: "   . $new->{method}      . "\n");

        push @DewiInternal::regfiles, $new;
    }

    return 1;
}

sub register {
    $reg_calls++;
    my ($arg) = @_;
    my $type = ref $arg;

    if ($type eq '') {
        my ($nodot, $symlink) = (0, 0);
        my $p = Getopt::Long::Parser->new();
        $p->configure(qw{ require_order no_gnu_compat no_ignore_case });
        $p->getoptionsfromarray(\@_,
                                q{no-dotfile} => \$nodot,
                                q{symlink} => \$symlink);
        die "usage: register( OPTION(s), ..., FILENAME );\n" if ($#_ != 0);
        debug("register(): --no-dotfile option used in trivial call.\n") if ($nodot != 0);
        debug("register(): --symlink option used in trivial call.\n") if ($symlink != 0);
        my ($arg) = @_;
        my $hr = { glob      => "$arg",
                   method    => (($symlink == 0) ? "copy" : "symlink"),
                   transform => (($nodot == 0) ? \&makedotfile : \&notransform) };
        __register_defaults($hr);
        __register($hr);
    } elsif ($type eq 'HASH') {
        die "usage: register( { foo => val0, bar => val1, ... } );\n" if ($#_ != 0);
        __register_defaults($arg);
        __register($arg);
    } else {
        die
        "The argument to the register function must be either one\n".
        "or more scalar values or exactly one hash reference.\n";
    }

    return 1;
}

# Dewifile reader
sub read_dewifile {
    my ($file) = @_;
    my ($d, $rc);

    if (!-e $file) {
        warn qq{dewi: $file does not exist!\n};
        return 0;
    }

    $file = DewiInternal::merge_name(Cwd::abs_path(Cwd::getcwd()), $file)
        unless (File::Spec->file_name_is_absolute($file));
    $rc = do $file;
    if (blessed($EVAL_ERROR)) {
        my $ev = $EVAL_ERROR;
        if ($ev->isa(q{Dewi::Exceptions::EarlyExit})) {
            $ev->print_output();
            warn q{dewi: Early exit from package: } . $DEWI{PACKAGE} . qq{\n}
                unless ($ev->be_silent());
            if (defined $ev->do_exit()) {
                exit $ev->do_exit();
            }
            return $ev->do_deploy();
        } else {
        warn qq{read_dewifile: Unknown exception: $EVAL_ERROR\n};
        return 0;
        }
    } elsif (!defined $rc && $EVAL_ERROR) {
        warn qq{Could not parse $file:\n  - Reason: $EVAL_ERROR\n};
        return 0;
    } elsif (!defined $rc) {
        if ($EVAL_ERROR eq '') {
            warn qq{$file empty?\n};
        } else {
            warn qq{Could not read $file:\n  - Reason: $ERRNO\n};
        }
        return 0;
    } elsif ($rc != 1) {
        warn qq{Reading $file did not return 1.\n}
        ."  While this is not a fatal problem, it is good practice, to let\n"
        ."  perl script files return 1. Just put a '1;' into the last line\n"
        ."  of this file to get rid of this warning.\n";
    }

    return 1;
}

# place holder function for the bootstrapping functionality
sub dewifile_is_empty {
    print
"Empty package: " . $DEWI{PACKAGE} . "\n".
"This Dewifile is empty. Is was probably created by dewi's bootstrap mode.\n".
"You will need to register the files you want dewi to deploy. This is\n".
"merely a placeholder.   Thanks for your attention.\n";
}

# a glorified '1;' for the end of Dewifiles
sub end {
    return 1;
}

sub early_exit {
    my $exception = Dewi::Exceptions::EarlyExit->new( { arguments => \@_ } );
    foreach my $argument (@_) {
        my $type = ref $argument;
        if ($type eq q{HASH}) {
            $exception->add_config($argument);
        } elsif ($type eq q{ARRAY} || $type eq q{}) {
            $exception->add_output($argument);
        } else {
            warn qq{usage: early_exit( [ARRAYREF|HASHREF|SCALAR]... )\n};
            exit 1;
        }
    }
    die $exception;
}

sub callsite {
    return $main::callsite;
}

###########################################################################

package DewiInternal;

use strict;
use warnings qw(all);
use English '-no_match_vars';
use Cwd;
use File::Basename;
use File::Copy;
use File::Spec;
use Scalar::Util qw{ blessed };

my %optional_features = (
    external_filters => "tobeseen",
    templates => "tobeseen"
);

eval {require IPC::Run3;};
if ($EVAL_ERROR) {
    $optional_features{external_filters} = 'missing';
} else {
    $optional_features{external_filters} = 'gotit';
}

eval {require Template;};
if ($EVAL_ERROR) {
    $optional_features{templates} = 'missing';
} else {
    $optional_features{templates} = 'gotit';
}

our $NAME = 'dewi';
our $MAJOR_VERSION = @@MAJOR_VERSION@@;
our $MINOR_VERSION = @@MINOR_VERSION@@;
our $SUFFIX_VERSION = @@VERSION_SUFFIX@@;
our $FULL_VERSION = @@FULL_VERSION@@;
our $VERSION = $MAJOR_VERSION . '.' . $MINOR_VERSION . $SUFFIX_VERSION;

# Default set of options. This will be the fallback storage for per-package
# option sets as well.
our $options = Dewi::Storage::Options->new();
$options->set(q{filter_always}, q{no});
$options->set(q{debug}, q{no});
$options->set(q{dryrun}, q{no});
$options->set(q{verbose}, q{no});

# The user-settings work exactly like $options do. But the namespace it
# entirely for the user to control. Dewi will never do near it internally.
our $user_settings = Dewi::Storage::Options->new();

# Just like options and user-settings, hooks get global and per-package
# storages as implemented by the class we're instantiating right here:
our $hooks = Dewi::Storage::Hooks->new();

our @regfiles;

my %methods = (
    copy       => \&method_copy,
    filtered   => \&method_filtered,
    force_copy => \&method_force_copy,
    hardlink   => \&method_hardlink,
    symlink    => \&method_symlink,
    template   => \&method_template
);

sub method_exists {
    my ($method) = @_;

    if (defined $methods{$method}) {
        return 1;
    }
    return 0;
}

sub dewi_got_feature {
    my ($f) = @_;

    if (defined $optional_features{$f} && $optional_features{$f} eq 'gotit') {
        return 1;
    }
    return 0;
}

sub clear_state {
    @regfiles = ( );
}

sub run_coderef {
    my $desc = shift;
    my $code = shift;
    my (@list, $scalar);
    my $wantarray = wantarray();
    my $debug = __get_opt_bool($options, $DewiFile::local_options, q{option}, q{debug});
    if ($debug) {
        print qq{run_coderef(): Running a code reference for $desc\n};
        print q{run_coderef(): Calling context is: };
        if (!defined $wantarray) {
            print q{void};
        } elsif ($wantarray) {
            print q{list};
        } else {
            print q{scalar};
        }
        print qq{\n};
    }
    my $rc = eval {
        if (!defined $wantarray) {
            $code->(@_);
        } elsif ($wantarray) {
            @list = $code->(@_);
        } else {
            $scalar = $code->(@_);
        }
    };
    if (blessed($EVAL_ERROR)) {
        my $ev = $EVAL_ERROR;
        if ($ev->isa(q{Dewi::Exceptions::EarlyExit})) {
            $ev->print_output();
            warn qq{dewi: Early exit from $desc.\n} unless ($ev->be_silent());
            if (defined $ev->do_exit()) {
                exit $ev->do_exit();
            }
        } else {
            warn qq{dewi: Unknown exception: $EVAL_ERROR\n};
        }
    } elsif (!defined $rc) {
        warn qq{dewi: $EVAL_ERROR};
    }
    return unless (defined $wantarray);
    return @list if ($wantarray);
    return $scalar;
}

# Option helpers, use the settings from DewiFile if they are defined.

sub __set_opt {
    my ($global, $local, $desc, $key, $value) = @_;
    my $debug = __get_opt_bool($options, $DewiFile::local_options, q{option}, q{debug});
    my ($rc, $lg);

    if (defined $local) {
        $rc = $local->set($key, $value);
        $lg = q{local};
    } else {
        $rc = $global->set($key, $value);
        $lg = q{global};
    }
    print qq{set_opt(): Setting $lg $desc $key to $value\n} if ($debug);
    return $rc;
}

sub __get_opt {
    my ($global, $local, $desc, $key) = @_;
    my $debug = __get_opt_bool($options, $DewiFile::local_options, q{option}, q{debug});
    my ($rc, $lg);

    if (defined $local) {
        $rc = $local->get($key);
        $debug = $local->getopt_bool(q{debug});
        $lg = q{local};
    } else {
        $rc = $global->get($key);
        $debug = $global->getopt_bool(q{debug});
        $lg = q{global};
    }
    print qq{get_opt(): Getting value for $lg $desc $key: $rc\n} if ($debug);
    return $rc;
}

sub __get_opt_bool {
    my ($global, $local, $desc, $key) = @_;
    my ($rc, $lg);

    if ($global == $options &&
        (!defined $local || $local == $DewiFile::local_options) &&
        $key eq q{debug})
    {
        return $local->getopt_bool($key) if (defined $local);
        return $global->getopt_bool($key);
    }

    my $debug = __get_opt_bool($options, $DewiFile::local_options, q{option}, q{debug});
    if (defined $local) {
        $rc = $local->getopt_bool($key);
        $lg = q{local};
    } else {
        $rc = $global->getopt_bool($key);
        $lg = q{global};
    }
    print qq{get_opt_bool(): Getting boolean value for $lg $desc $key: }
        . ($rc ? q{true} : q{false}) . qq{\n} if ($debug);
    return $rc;
}

sub set_opt {
    my ($key, $value) = @_;
    return __set_opt($options, $DewiFile::local_options, q{option}, $key, $value);
}

sub set_opt_default {
    my ($key, $value) = @_;
    return __set_opt($options, undef, q{option}, $key, $value);
}

sub get_opt {
    my ($key) = @_;
    return __get_opt($options, $DewiFile::local_options, q{option}, $key);
}

sub get_opt_default {
    my ($key) = @_;
    return __get_opt($options, undef, q{option}, $key);
}

sub get_opt_bool {
    my ($key) = @_;
    return __get_opt_bool($options, $DewiFile::local_options, q{option}, $key);
}

sub get_opt_bool_default {
    my ($key) = @_;
    return __get_opt_bool($options, undef, q{option}, $key);
}

sub user_set {
    my ($key, $value) = @_;
    return __set_opt($user_settings, $DewiFile::user_settings, q{user setting},
                     $key, $value);
}

sub user_set_default {
    my ($key, $value) = @_;
    return __set_opt($user_settings, undef, q{user setting}, $key, $value);
}

sub user_get {
    my ($key) = @_;
    return __get_opt($user_settings, $DewiFile::user_settings, q{user setting},
                     $key);
}

sub user_get_default {
    my ($key) = @_;
    return __get_opt($user_settings, undef, q{user setting}, $key);
}

sub user_get_bool {
    my ($key) = @_;
    return __get_opt_bool($user_settings, $DewiFile::user_settings,
                          q{user setting}, $key);
}

sub user_get_bool_default {
    my ($key) = @_;
    return __get_opt_bool($user_settings, undef, q{user setting}, $key);
}

# output
sub verbose {
    print @_ if (get_opt_bool('verbose') || get_opt_bool('debug'));
    return 1;
}

sub debug {
    print @_ if (get_opt_bool('debug'));
    return 1;
}

# setup the DEWI hash
sub set_dewi_hash {
    my ($mode) = @_;
    %DewiFile::DEWI = (
        NAME                => $NAME,
        MAJOR_VERSION       => $MAJOR_VERSION,
        MINOR_VERSION       => $MINOR_VERSION,
        SUFFIX_VERSION      => $SUFFIX_VERSION,
        PATCH_LEVEL         => @@PATCH_LEVEL@@,
        SOURCE_CODE_SOURCE  => @@SOURCE_CODE_SOURCE@@,
        FULL_VERSION        => $FULL_VERSION,
        VERSION             => $VERSION,
        VERSION_DATE        => @@VERSION_DATE@@,
        VERSION_DESCRIPTION => @@VERSION_DESCRIPTION@@,
        WORK_DIR_STATE      => @@WORK_DIR_STATE@@,
        PERL                => @@PERL5_QUOTED@@,
        POSIX_SH            => @@POSIX_SH@@,
        CHECKSUM            => @@VERSION_CHECKSUM@@,
        DATA_DIR            => @@DATADIR@@,
        BASE_DIR            => base_dir($mode),
        DOT_DEWI            => dot_dewi($mode),
        PACKAGE             => dewi_package($mode)
    );
}

sub base_dir {
    my ($mode) = @_;
    return if (defined $mode && $mode eq q{dewirc});
    return Cwd::abs_path(Cwd::getcwd()) if (defined $mode && $mode eq q{fromroot});
    return Cwd::abs_path(basename(Cwd::getcwd() . "/.."))
}

sub dot_dewi {
    my ($mode) = @_;
    return if (defined $mode && $mode eq q{dewirc});
    my $base = base_dir($mode);
    my $dd = "$base/.dewi";

    if (! -d $dd) {
        die "No .dewi in '$base'. Giving up.\n";
    }

    return $dd;
}

sub dewi_package {
    my ($mode) = @_;
    return undef if (defined $mode);
    return basename(Cwd::abs_path(Cwd::getcwd()));
}

# utilities
sub expand_dir {
    my ($str) = @_;

    $str =~ s!^~!$ENV{HOME}!;
    $str =~ s/\/+$//;
    return $str;
}

sub run_dot_dewi_script {
    my ($script, @args) = @_;
    my (@cmd, $rc);

    if (get_opt_bool('dryrun')) {
        return 0;
    }
    @cmd = (@@POSIX_SH@@, $DEWI{DOT_DEWI} . $script);
    push @cmd, @args if ($#args >= 0);
    system @cmd;
    $rc = $?;

    if ($rc == -1) {
        die "run_dot_dewi_script(): `system()' failed!\n";
    }
    return $rc;
}

sub xcopy {
    my ($src, $dst) = @_;

    if (get_opt_bool('dryrun')) {
        return 1;
    }
    copy($src, $dst) or die "copy($src, $dst) failed: $ERRNO\n";
    return 1;
}

sub xdir_is_empty {
    my ($dir) = @_;
    my ($dh);

    opendir $dh, $dir or die "xdir_is_empty(): Could not open $dir: $ERRNO\n";
    if (scalar(grep(!/^\.\.?$/, readdir($dh)) == 0)) {
        closedir $dh;
        return 1;
    }
    closedir $dh;
    return 0;
}

sub xhardlink {
    my ($src, $dst) = @_;

    if (get_opt_bool('dryrun')) {
        return 1;
    }

    link Cwd::realpath($src), $dst
        or die "Could not create hardlink: $ERRNO\n";
}

sub xrmdir {
    # Assumes that it is never called in dryrun mode.
    my ($dir) = @_;

    rmdir $dir or die "rmdir() failed: $ERRNO\n";
}

sub xsymlink {
    my ($src, $dst) = @_;

    if (get_opt_bool('dryrun')) {
        return 1;
    }

    if (not -e $src) {
        warn "Source does not exist: $src\n";
        return 0;
    }

    if (-l $dst) {
        # if we're here, $dst exists, is a symlink but links somewhere
        # else. Remove it, so the symlink() below can succeed.
        xunlink($dst);
    }
    symlink Cwd::realpath($src), $dst
        or die "Could not create symlink ($src to $dst): $ERRNO\n";
}

sub stat_names {
    my ($num) = @_;
    my @names = qw{ dev ino mode nlink uid gid rdev size
                    atime mtime ctime blksize blocks };

    return $names[$num];
}

sub xstat {
    my ($file) = @_;
    my ($i, %stat, @data);

    @data = stat($file);
    $i = 0;
    %stat = map { stat_names($i++) => $_ } @data;
    if (-e _) {
        $stat{exist} = 1;
    } else {
        $stat{exist} = 0;
    }

    $stat{plainfile} = 0;
    $stat{dir} = 0;
    if (-f _) {
        $stat{plainfile} = 1;
    } elsif (-d _) {
        $stat{dir} = 1;
    }
    return \%stat;
}

sub xunlink {
    my ($file) = @_;

    if (get_opt_bool('dryrun')) {
        return 1;
    }

    unlink $file or die "unlink() failed: $ERRNO\n";
}

sub ensure_dir {
    # think: mkdir -p /foo/bar/baz
    my ($wantdir) = @_;
    my (@parts, $sofar);

    if (-d $wantdir) {
        return 1;
    }

    if ($wantdir =~ q{^/}) {
        $sofar = q{/};
    } else {
        $sofar = q{};
    }

    @parts = split /\//, $wantdir;
    foreach my $part (@parts) {
        if ($part eq q{}) {
            next;
        }
        $sofar = (
                  $sofar eq q{}
                    ? $part
                    : (
                        $sofar eq q{/}
                          ? q{/} . $part
                          : $sofar . q{/} . $part
                      )
                 );

        if (!-d $sofar) {
            if (!get_opt_bool('dryrun')) {
                verbose("  _mkdir(): $sofar\n");
                mkdir $sofar
                    or die "Could not mkdir($sofar).\n" . "Reason: $ERRNO\n";
            }
        }
    }

    return 1;
}

# aaaand ACTION.
sub merge_name {
    my ($dest, $file) = @_;
    return File::Spec->catfile($dest, $file);
}

sub method_copy {
    my ($f) = @_;
    my ($src, $dst) = ($f->{path}, $f->{mergedname});
    my ($dstat, $sstat);

    $sstat = xstat($src);
    $dstat = xstat($dst);
    if (($dstat->{exist} == 1) && ($sstat->{ino} == $dstat->{ino})) {
        die "  _copy(): $src and $dst are the same file. Please resolve!\n";
    }
    if (($dstat->{exist} == 1) && ($sstat->{mtime} <= $dstat->{mtime})) {
        verbose("  _copy(): $dst (source is not newer, skipping)\n");
        debug("   source: $src\n");
        return 1;
    }
    verbose("  _copy(): $dst\n");
    debug("   source: $src\n");
    xcopy($src, $dst);
}

sub __filter_perl {
    my ($f) = @_;
    my ($filter, $src, $dst, $cat) = ($f->{filter},
                                      $f->{path},
                                      $f->{mergedname},
                                      $f->{concatenate});
    my ($in, $out, $mode);

    return 1 if (get_opt_bool('dryrun'));
    if (!defined $cat) {
        $mode = q{>};
    } else {
        $mode = q{>>};
    }
    open $in, "<", $src or die "Could not open `$src': $ERRNO\n";
    open $out, $mode, $dst or die "Could not open `$dst': $ERRNO\n";

    while (my $line = <$in>) {
        chomp $line;
        $line = run_coderef(q{filter callback}, $filter, $line);
        print {$out} "$line\n";
    }

    close $out;
    close $in;
}

sub __filter_shell_file {
    my ($f) = @_;
    my ($filter, $src, $dst, $cat) = ($f->{filter},
                                      $f->{path},
                                      $f->{mergedname},
                                      $f->{concatenate});
    my ($cmd, $mode);

    if (!dewi_got_feature('external_filters')) {
        print "Cannot run `shell-file' filter as required.\n";
        print "This dewi has no support for external filters. Giving up.\n";
        return 1;
    }
    return 1 if (get_opt_bool('dryrun'));

    if (!defined $cat) {
        $mode = 0;
    } else {
        $mode = 1;
    }
    $cmd = [ @@POSIX_SH@@, "$filter" ];
    IPC::Run3::run3($cmd, $src, $dst, undef, { append_stdout => $mode });
}

sub __filter_shell_inline {
    my ($f) = @_;
    my ($filter, $src, $dst, $cat) = ($f->{filter},
                                      $f->{path},
                                      $f->{mergedname},
                                      $f->{concatenate});
    my ($cmd, $mode);

    if (!dewi_got_feature('external_filters')) {
        print "Cannot run `shell-inline' filter as required.\n";
        print "This dewi has no support for external filters. Giving up.\n";
        return 1;
    }
    return 1 if (get_opt_bool('dryrun'));

    if (!defined $cat) {
        $mode = 0;
    } else {
        $mode = 1;
    }
    $cmd = [ @@POSIX_SH@@, '-c', "$filter" ];
    IPC::Run3::run3($cmd, $src, $dst, undef, { append_stdout => $mode });
}

sub __filter {
    my ($f) = @_;
    my ($type) = ($f->{filtertype});

    if ($type eq 'perl') {
        __filter_perl($f)
    } elsif ($type eq 'shell-file') {
        __filter_shell_file($f)
    } elsif ($type eq 'shell-inline') {
        __filter_shell_inline($f)
    } else {
        die "__filter(): Unknown filter type `$type'\n";
    }
}

sub __run_cat_cb {
    my ($f, $cb) = @_;
    my $fun = $f->{intercat}->{$cb};
    my $sptype = $f->{intercat}->{$cb . 'type'};
    my $type = defined $sptype ? $sptype : $f->{intercat}->{type};

    if (!dewi_got_feature('external_filters')
        && (defined $type && $type =~ m/^shell-(file|inline)$/))
    {
        warn "WARNING: External `intercat' callbacks require the"
           . " `external_filters'\n  feature provided by IPC::Run3 which is"
           . " not available here.\n";
        return 0;
    }

    if (defined $fun) {
        my @args = ($cb,
                    $f->{path},
                    $f->{srcdir},
                    $f->{name},
                    $f->{transformed},
                    $f->{concatenate},
                    $f->{mergedname});

        if (ref $fun eq 'CODE') {
            local(*STDOUT);
            open *STDOUT, q{>>}, $f->{mergedname}
                or die "Couldn't open " . $f->path . " for appending.\n";
            run_coderef(q{intercat callback}, $fun, @args);
            close *STDOUT;
        } elsif ($type eq 'shell-file') {
            local(%ENV);
            $ENV{DEWI_HOOK_EVENT} = $args[0];
            shift @args;
            IPC::Run3::run3([@@POSIX_SH@@, $fun, @args],
                            undef,
                            $f->{mergedname},
                            undef,
                            { append_stdout => 1 });
        } elsif ($type eq 'shell-inline') {
            local(%ENV);
            $ENV{DEWI_HOOK_EVENT} = $args[0];
            shift @args;
            for my $i (0 .. $#args) {
                $ENV{'DEWI_HOOK_ARG' . $i} = $args[$i];
            }
            IPC::Run3::run3([@@POSIX_SH@@, q{-c}, $fun],
                            undef,
                            $f->{mergedname},
                            undef,
                            { append_stdout => 1 });
        }
    }
    return 1;
}

sub method_filtered {
    my ($f) = @_;
    my ($src, $dst, $cat) = ($f->{path}, $f->{mergedname}, $f->{concatenate});
    my ($dstat, $sstat);

    $sstat = xstat($src);
    $dstat = xstat($dst);
    if (($dstat->{exist} == 1) && ($sstat->{ino} == $dstat->{ino})) {
        die "  _filtered(): $src and $dst are the same file. Please resolve!\n";
    }
    if ((!get_opt_bool('filter_always') && !defined $f->{needsrefresh})
            && ($dstat->{exist} == 1) && ($sstat->{mtime} <= $dstat->{mtime}))
    {
        verbose("  _filtered(): $dst (source is not newer, skipping)\n");
        debug("       source: $src\n");
        return 1;
    }

    if (defined $f->{catfirst}) {
        truncate $dst, 0;
        __run_cat_cb($f, 'firstpre');
    } elsif (defined $f->{catlast}) {
        __run_cat_cb($f, 'lastpre');
    } elsif (defined $f->{concatenate}) {
        __run_cat_cb($f, 'otherpre');
    }

    verbose("  _filtered(): $dst" . (defined $cat ? " [concat: $src]" : "")
                                  . "\n");
    debug("       source: $src\n");
    __filter($f);

    if (defined $f->{catfirst}) {
        __run_cat_cb($f, 'firstpost');
    } elsif (defined $f->{catlast}) {
        __run_cat_cb($f, 'lastpost');
    } elsif (defined $f->{concatenate}) {
        __run_cat_cb($f, 'otherpost');
    }
}

sub method_force_copy {
    my ($f) = @_;
    my ($src, $dst) = ($f->{path}, $f->{mergedname});
    my ($dstat, $sstat);

    $sstat = xstat($src);
    $dstat = xstat($dst);
    if (($dstat->{exist} == 1) && ($sstat->{ino} == $dstat->{ino})) {
        die
        "  _force_copy(): $src and $dst are the same file. Please resolve!\n";
    }
    verbose("  _force_copy(): $dst\n");
    debug("         source: $src\n");
    xcopy($src, $dst);
}

sub method_hardlink {
    my ($f) = @_;
    my ($src, $dst) = ($f->{path}, $f->{mergedname});
    my ($dstat, $sstat);

    $sstat = xstat($src);
    $dstat = xstat($dst);
    if (($dstat->{exist} == 1) && ($sstat->{ino} == $dstat->{ino})) {
        verbose("  _hardlink(): $dst (hardlinked to source, skipping)\n");
        debug("       source: $src\n");
        return 1;
    }
    verbose("  _hardlink(): $dst\n");
    debug("       source: $src\n");
    xhardlink($src, $dst);
}

sub method_symlink {
    my ($f) = @_;
    my ($src, $dst) = ($f->{path}, $f->{mergedname});
    my ($not_a_symlink);

    if (-l $dst) {
        $not_a_symlink = 0;
        my ($sstat, $tstat, $t);
        $t = readlink $dst or die "  _symlink(): readlink() failed: $ERRNO\n";
        $tstat = xstat($t);
        $sstat = xstat($src);
        if (($tstat->{exist} == 1) && ($tstat->{ino} == $sstat->{ino})) {
            verbose("  _symlink(): $dst (symlinked to source, skipping)\n");
            debug("      source: $src\n");
            return 1;
        }
    } else {
        $not_a_symlink = 1;
    }

    if ($not_a_symlink && -e $dst) {
        die
        "  _symlink(): destination $dst exists but is not a symlink.\n" .
        "              Please resolve!\n";
    }
    verbose("  _symlink(): $dst\n");
    debug("      source: $src\n");
    xsymlink($src, $dst);
}

sub method_template {
    my ($f) = @_;
    my ($tt);
    my ($src, $dst, $data, $opts) = ($f->{path}, $f->{mergedname},
                                     $f->{data}, $f->{options});

    if (!dewi_got_feature('templates')) {
        print "$src: Cannot use `template' method. The Template module is missing.\n";
        return 1;
    }
    verbose("  _template(): $dst\n");
    debug("      source: $src\n");
    return 1 if (get_opt_bool('dryrun'));

    $tt = Template->new() || die $tt->error(), "\n";
    $tt->process($src, $data, $dst, $opts) || die $tt->error(), "\n";
}

sub deploy_files {
    my ($base) = @_;

    run_hook('pre-deploy', \$base);
    print "Deploying $base...\n";
    foreach my $f (@regfiles) {
        ensure_dir($f->{destination});
        if (defined $f->{deploydir} && $f->{deploydir} eq 'yes') {
            next;
        }
        $methods{$f->{method}}->($f);
    }
    run_hook('post-deploy', \$base);
}

sub withdraw_files {
    my ($base) = @_;
    my (%dests);

    run_hook('pre-withdraw', \$base);
    print "Withdrawing $base...\n";
    foreach my $f (@regfiles) {
        if (!defined $dests{$f->{destination}}) {
            $dests{$f->{destination}} = 'xxx';
        }
        if (defined $f->{deploydir} && $f->{deploydir} eq 'yes') {
            next;
        }
        if (defined $f->{concatenate} && !defined $f->{catfirst}) {
            next;
        }

        if (!-e $f->{mergedname}) {
            verbose("  withdraw: " . $f->{mergedname}
                . " does not exist. Ignoring.\n");
        } else {
            verbose("  withdraw: unlink(" . $f->{mergedname} . ")\n");
            xunlink($f->{mergedname});
        }
    }

    foreach my $d (sort { length $b <=> length $a } keys %dests) {
        if (!-d $d) {
            verbose("  withdraw: $d does not exist. Ignoring.\n");
            next;
        }
        if (Cwd::realpath($d) eq Cwd::realpath($ENV{HOME})) {
            # no, we're not removing ~.
            next;
        }
        if (get_opt_bool('dryrun')) {
            verbose("  dryrun: Test if $d is empty and if so remove it.\n");
        } elsif (xdir_is_empty($d)) {
            verbose(
                "  withdraw: rmdir($d) (empty directory)\n");
            xrmdir($d);
        } else {
            verbose("  withdraw: `$d' is not empty. Leaving it alone.\n");
        }
    }
    run_hook('post-withdraw', \$base);
}

# hooks
sub register_hook {
    my ($event, $hr) = @_;

    my $place = q{end};
    if (defined $hr->{place}) {
        $place = $hr->{place};
        delete($hr->{place});
    }
    my $l = $DewiFile::local_hooks;
    my $store = (defined $l) ? $l : $hooks;
    if ($place eq q{start}) {
        $store->add($event, $hr);
    } else {
        $store->push($event, $hr);
    }
    return 1;
}

sub run_shell_hook_file {
    my ($ev, $file, @args) = @_;
    my (@cmd);

    push @cmd, @@POSIX_SH@@;
    foreach my $scal (@args) {
        push @cmd, $$scal;
    }
    $ENV{DEWI_HOOK_EVENT} = $ev;
    system(@cmd);
    delete($ENV{DEWI_HOOK_EVENT});
}

sub run_shell_hook_inline {
    my ($ev, $code, @args) = @_;
    my (@env_args, $i);

    $ENV{DEWI_HOOK_EVENT} = $ev;
    $i = 0;
    foreach my $scal (@args) {
        push @env_args, "DEWI_HOOK_ARG$i";
        $ENV{"DEWI_HOOK_ARG$i"} = $$scal;
        $i++;
    }
    system((@@POSIX_SH@@, '-c', $code));
    delete($ENV{DEWI_HOOK_EVENT});
    foreach my $key (@env_args) {
        delete($ENV{$key});
    }
}

sub run_hook {
    # The @args should be a set of scalar references. They *must* be references,
    # in fact, because `run_shell_hook_file()' dereferences them before passing
    # the scalars as arguments to the script file. `run_shell_hook_inline()'
    # behaves similarly.
    my ($event, @args) = @_;

    my $l = $DewiFile::local_hooks;
    my $hr = (defined $l) ? $l : $hooks;
    my $list = $hr->get($event);
    return 0 if (!defined $list || scalar @{ $list } == 0);

    foreach my $h (@{ $list }) {
        if ($h->{type} eq 'perl') {
            run_coderef(qq{$event hook}, $h->{code}, $event, @args);
        } elsif ($h->{type} eq 'shell-file') {
            run_shell_hook_file($event, $h->{code}, @args);
        } elsif ($h->{type} eq 'shell-inline') {
            run_shell_hook_inline($event, $h->{code}, @args);
        } else {
            die "BUG: Unknown hook type: " . $h->{type} . ". Giving up.\n";
        }
    }

    return 1
}

# Post processing `@regfiles'
sub mark_first {
    my ($needle, $marker, $dat) = @_;
    my (%keep);

    foreach my $e (@{ $dat }) {
        if (defined $e->{$needle} && !defined $keep{$e->{mergedname}}) {
            $e->{$marker} = 1;
            $keep{$e->{mergedname}} = 'seen';
        }
    }

    return 1;
}

sub concatenate_dependencies {
    my (%prev, %todo, %stats);
    my ($key) = ('needsrefresh');

    foreach my $e (@regfiles) {
        my ($f, $m) = ($e->{path},
                       $e->{mergedname});

        # If $m is not defined, it's not for us (`deploydir' maybe).
        next if (!defined $m);
        if (!defined $stats{$m}) {
            $stats{$m} = xstat($m);
        }

        if (defined $todo{$m}) {
            $e->{$key} = 1;
        } elsif (sub { my $s = xstat($f);
                       return 1 if (($stats{$m}->{exist} == 0)
                                        || ($s->{mtime} > $stats{$m}->{mtime}));
                       return 0}->()) {
            $todo{$m} = 1;
            $e->{$key} = 1;
            foreach my $old (@{ $prev{$m} }) {
                $old->{$key} = 1;
            }
        } else {
            push @{ $prev{$m} }, $e;
        }
    }
}

sub post_process_req_files {
    # The `concatenate' feature needs to know what the first part of a
    # concatenation is, so it can truncate the destination file beforehand.
    mark_first('concatenate', 'catfirst', \@regfiles);
    # For more features, `concatenate' also needs to know the last part of a
    # concatenation...
    mark_first('concatenate', 'catlast', [ reverse @regfiles ]);
    # Also with `concatenate', a destination file depends on several source
    # files. Now we could opt to just regenerate concatenate files every time,
    # _or_ we just check if at least one of the input files are newer then the
    # destination. Needs to be done here, because the rest of the code works
    # file by file.
    concatenate_dependencies();
}

###########################################################################

package main;

use strict;
use warnings qw(all);
use English '-no_match_vars';
use Cwd;
use File::Basename;
use File::Copy;

our $callsite = q{unclear};

# Helpers for the operations dispatch table

sub xeq {
    my ($val0, $val1) = @_;
    return 1 if ($val0 == $val1);
    return 0;
}

sub xge {
    my ($val0, $val1) = @_;
    return 1 if ($val0 >= $val1);
    return 0;
}

sub xrange {
    my ($val, $min, $max) = @_;
    return 1 if ($val >= $min && $val <= $max);
    return 0;
}

# Operations dispatch table

my %ops = (
    deploy => { cb => \&op_deploy,
                args => sub { xge($_[0], 0) },
                info => q{Deploy registered files} },
    completion => { cb => \&op_completion,
                    info => q{Query for suitable completion results},
                    args => sub { xeq($_[0], 1) } },
    foreach => { cb => \&op_foreach,
                 info => q{Run command in dewi-fied sub-directories},
                 args => sub { xge($_[0], 0) } },
    help => { cb => \&op_help,
              info => q{Show this help text} },
    init => { cb => \&op_init,
              info => q{Initialise .dewi directory or sub-directory},
              args => sub { xrange($_[0], 0, 1) } },
    version => { cb => \&op_version,
                 info => q{Show version information} },
    withdraw => { cb => \&op_withdraw,
                  args => sub { xge($_[0], 0) },
                  info => q{Withdraw registered files} } );

# Completion helpers dispatch table

my %completions = (
    operations => \&cmpl_operations );

# Operation handlers

sub op_completion {
    my $cmpl = $ARGV[1];
    $completions{$cmpl}->() if (defined $completions{$cmpl});
}

sub op_deploy {
    dewi(q{deploy});
}

sub op_foreach {
    shift @ARGV;
    if (! -t STDIN) {
        DewiInternal::debug("stdin not connected to a terminal.\n");
        DewiInternal::debug("Reading script from stdin therefore.\n");
        DewiInternal::debug("Ignoring any other arguments.\n");
        my @script = ();
        while (my $line = <STDIN>) {
            push @script, $line;
        }
        map { dewi_foreach($_, \@script) } dewi_subdirs();
    } else {
        map { dewi_foreach($_) } dewi_subdirs();
    }
}

sub op_help {
    print <<EOF
  +-------------------------------------------------+
  | dewi - deploy and withdraw configuration files  |
  +-------------------------------------------------+

usage: dewi <operation>

Where operation is one of:
EOF
;
    map {printf q{  %-12s    %s.}.qq{\n}, $_, $ops{$_}->{info}} sort keys %ops;
    print qq{\n};
}

sub op_init {
    my $sd = $ARGV[1];
    if ($callsite eq q{dewi-root}) {
        # Init sub-dir below dewi-root
        return init_subdir($sd) if (defined $sd);
        die "dewi: `init' in dewi-root needs to specify sub-directory!\n";
    } elsif ($callsite eq q{subdirectory-uninitialized}) {
        return init_subdir(q{.});
    } elsif ($callsite eq q{subdirectory}) {
        die "dewi: Naming a sub-directory is only valid"
            . " in a dewi-root directory!\n" if (defined $sd);
        return init_subdir(q{.});
    } else {
        die "dewi: root needs to be initialised before sub-directory!\n"
            if (defined $sd);
        return init_root();
    }
}

sub op_version {
    my $v = $DewiInternal::FULL_VERSION;
    $v =~ s{^v}{};
    print <<EOF
dewi version $v
EOF
;
}

sub op_withdraw {
    dewi(q{withdraw});
}

sub op_needs_root {
    my ($op) = @_;
    return 0 unless (defined $op);
    return 1 if ($op eq q{deploy});
    return 1 if ($op eq q{withdraw});
    return 1 if ($op eq q{completion});
    return 0;
}

# Completion helpers

sub cmpl_operations {
    map { printf q{%s:%s}.qq{\n}, $_, $ops{$_}->{info} } keys %ops;
}

# Utilities

sub _copy_dummy_dewi_file {
    my ($path) = @_;
    my ($dest);
    my $src = q{.dewi/Dewifile.stub};

    if ($path eq q{.}) {
        $src = q{../} . $src;
        $dest = q{Dewifile};
    } else {
        $dest = qq{$path/Dewifile};
    }
    DewiInternal::xcopy($src, $dest);
}

sub _init_dummy_dewi_file {
    my $f = q{.dewi/Dewifile.stub};
    open my $fh, q{>}, $f or die "Could not open `$f': $ERRNO\n";
    print {$fh} <<EOF
#!@@PERL5@@
# This is the placeholder Dewifile for freshly dewified subdirectories.
# Remove its content and fill it with something useful.

# Here is a bit example code to get you started:
#
#set_opt 'debug',   'true';
#set_opt 'dryrun',  'true';
#set_opt 'verbose', 'true';
#
# The simplest form of deployment would be:
#
#register 'my_rc_file';
#
# That way "my_rc_file" is _copied_ to "~/.my_rc_file". If you instead want to
# create a symlink, you will need to use the generic version of `register',
# that takes exactly one hash-ref argument:
#
#register { glob      => 'my_rc_file',
#           # Deploy things matched by "glob" using the "symlink" method:
#           method    => 'symlink',
#           # The generic version of `register' does not perform any
#           # name transformation by default. You could supply an anonymous
#           # function that does the trick here, but dewi provides a function
#           # that does the deed and it's called `makedotfile':
#           transform => \\\&makedotfile };

dewifile_is_empty;
EOF
;
    close $fh;
}

sub _copy_files_from_dir {
    my ($dir) = @_;
    my $src = @@DATADIR@@ . q{/} . $dir;
    DewiInternal::ensure_dir(qq{.dewi/$dir});
    return unless (-d $src);
    foreach my $file (_regular_files($src)) {
        DewiInternal::xcopy($file, $dir);
    }
}

sub _copy_global_dewifile {
    DewiInternal::xcopy(@@DATADIR@@ . q{/Dewifile}, q{.dewi});
}

sub _regular_files {
    my ($dir) = @_;

    opendir my $dh, $dir
        or die "dewi: Cannot read contents of ‘$dir’: $ERRNO\n";
    my @d = grep { -f $_ } readdir($dh);
    closedir $dh;
    return @d;
}

sub cd_and_do {
    my $subdir = shift;
    my $fnc = shift;
    chdir($subdir)
        or die "dewi: Could not change to directory `$subdir': $ERRNO\n";
    $fnc->(@_);
    chdir(q{..})
        or die "dewi: Could not change back to parent directory: $ERRNO\n";
}

sub cd_and_lib_dewi {
    my ($subdir, $op, $announce) = @_;
    print qq{dewi $op: $subdir\n} if ($announce);
    cd_and_do($subdir, sub { lib_dewi($op) });
}

sub dewi {
    my ($op) = @_;
    my $type = root_or_subdir_guard($op);

    if ($type eq q{root}) {
        DewiInternal::set_dewi_hash(q{fromroot});
        DewiFile::read_dewifile(Cwd::abs_path(q{.dewi/Dewifile}));
        shift @ARGV;
        my @pkgs;
        if ($#ARGV >= 0) {
            @pkgs = @ARGV;
        } else {
            @pkgs = dewi_subdirs();
        }
        my $announce = ($#pkgs > 0) ? 1 : 0;
        map { cd_and_lib_dewi($_, $op, $announce) } @pkgs;
    } else {
        DewiInternal::set_dewi_hash();
        DewiFile::read_dewifile(Cwd::abs_path(q{../.dewi/Dewifile}));
        lib_dewi($op, { hashisset => 1 });
    }
}

sub dewi_foreach {
    my ($subdir, $script) = @_;
    if (defined $script) {
        cd_and_do($subdir,
                  sub { print qq{dewi foreach: $subdir\n};
                        open(my $fh, q{|-}, @@POSIX_SH@@)
                            or die "Couldn't fork a shell: $ERRNO\n";
                        foreach my $line (@{ $script }) {
                            print {$fh} $line;
                        }
                        close($fh)});
    } else {
        my $code = join q{ }, @ARGV;
        cd_and_do($subdir, sub { print qq{dewi foreach: $subdir\n};
                                 system(@@POSIX_SH@@, q{-c}, $code); });
    }
}

sub dewi_subdirs {
    opendir my $dh, q{.}
        or die "dewi: Cannot read contents of current directory: $ERRNO\n";
    my @d = sort grep { ($_ !~ m/^(.|..|.dewi)$/)
                        && -d $_
                        && is_dewi_subdir($_) }
                 readdir($dh);
    closedir $dh;
    return @d;
}

sub got_dot_dewi {
    my ($path) = @_;
    $path = q{.} unless (defined $path);
    return 1 if (-d qq{$path/.dewi});
    return 0;
}

sub got_dewifile {
    my ($path) = @_;
    $path = q{.} unless (defined $path);
    return 1 if (-f qq{$path/Dewifile});
    return 0;
}

sub init_root {
    die "dewi: Current directory is already a dewi-root (.dewi exists)!\n"
        if ($callsite eq q{dewi-root});
    DewiInternal::ensure_dir(q{.dewi});
    _copy_global_dewifile();
    _init_dummy_dewi_file();
}

sub init_subdir {
    my ($path) = @_;
    die "dewi: Current directory already contains a Dewifile!\n"
        if (-f qq{$path/Dewifile});
    _copy_dummy_dewi_file($path);
}

sub is_dewi_root {
    my ($path) = @_;
    return got_dot_dewi($path);
}

sub is_dewi_subdir {
    my ($path) = @_;
    return 1 if (got_dewifile($path) && parent_dir_is_dewi_root($path));
    return 0;
}

sub lib_dewi {
    my ($op, $params) = @_;
    my $cwd = Cwd::cwd();
    my @dirs = File::Spec->splitdir($cwd);
    my $base = $dirs[-1];

    DewiInternal::clear_state();
    if (!defined $params->{hashisset} || $params->{hashisset} == 0) {
        DewiInternal::set_dewi_hash();
    }
    $DewiFile::local_options = Dewi::Storage::Options->new();
    $DewiFile::local_options->set_fallback($DewiInternal::options);
    $DewiFile::user_settings = Dewi::Storage::Options->new();
    $DewiFile::user_settings->set_fallback($DewiInternal::user_settings);
    $DewiFile::local_hooks = Dewi::Storage::Hooks->new();
    $DewiFile::local_hooks->set_fallback($DewiInternal::hooks);
    DewiFile::read_dewifile('Dewifile') or return 1;
    DewiInternal::post_process_req_files();

    print "dewi: --- This is a dry run ---\n"
        if (DewiInternal::get_opt_bool('dryrun'));

    if ($op eq q{deploy}) {
        DewiInternal::deploy_files($base);
    } elsif ($op eq q{withdraw}) {
        DewiInternal::withdraw_files($base);
    } else {
        die "dewi: BUG: Unknown operation `$op'!\n";
    }
    $DewiFile::local_options = undef;
    $DewiFile::user_settings = undef;
}

sub parent_dir_is_dewi_root {
    my ($path) = @_;
    $path = q{.} unless (defined $path);
    return 1 if (-d qq{$path/../.dewi});
    return 0;
}


sub root_or_subdir_guard {
    my ($op) = @_;
    return q{root} if ($callsite eq q{dewi-root});
    return q{subdir} if ($callsite eq q{subdirectory});
    die "dewi: `$op' is only valid in a dewi-root or sub-directory!\n";
}

sub subdir_guard {
    my ($op) = @_;
    die "dewi: $op is only valid in a dewi sub-directory!\n"
        unless ($callsite eq q{subdirectory});
}

sub update_callsite {
    if (is_dewi_root()) {
        $callsite = q{dewi-root};
    } elsif (is_dewi_root(q{..}) && !is_dewi_subdir()) {
        $callsite = q{subdirectory-uninitialized};
    } elsif (is_dewi_subdir()) {
        $callsite = q{subdirectory};
    } else {
        $callsite = q{unknown};
    }
}

# signals
$SIG{INT} = sub {
    print "dewi: Got SIGINT. Exiting failing, as requested.\n";
    exit 1;
};

$SIG{HUP} = sub {
    print "dewi: Got SIGHUP. Exiting succeeding, as requested.\n";
    exit 0;
};

# Top-level operations dispatch

if ($#ARGV < 0) {
    op_help();
    exit 1;
}
my $op = $ARGV[0];

update_callsite();
DewiInternal::set_dewi_hash(q{dewirc});
my $dewirc = Cwd::abs_path($ENV{HOME} . q{/.dewirc});
if (defined $dewirc && -f $dewirc && -r $dewirc) {
    DewiFile::read_dewifile($dewirc);
    my $root = $DewiInternal::options->get(q{default-root-directory});
    if (op_needs_root($op) && defined $root && $callsite eq q{unknown}) {
        $root = DewiInternal::expand_dir($root);
        if (ref $root ne q{}) {
            die qq{dewi: default-root-directory needs to be a string!\n};
        } elsif (!-d $root) {
            die qq{dewi: default-root-directory needs to be a directory!\n};
        } else {
            print qq{dewi: Switch to default-root-directory: $root\n}
                unless ($op eq q{completion});
            chdir($root) or die
                  qq{dewi: Could not change directory to $root}
                . qq{ (default-root-directory): $ERRNO\n};
            update_callsite();
        }
    }
}

if (defined $ops{$op}) {
    if (defined $ops{$op}->{args}){
        unless ($ops{$op}->{args}->($#ARGV)) {
            op_help();
            exit 1;
        }
    } elsif ($#ARGV != 0) {
        op_help();
        exit 1;
    }
    $ops{$op}->{cb}->();
} else {
    op_help();
    exit 1;
}

exit 0;