clonie

#!/usr/bin/env perl

# Copyright (c) 2021, 2022 Stefan Blachmann
# All rights reserved.

# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

use strict;
use warnings;
use utf8;
use open ':encoding(utf8)';
binmode(STDOUT, ":utf8");
use feature 'unicode_strings';
use Getopt::Long;
use Data::Dumper;

my $fakerun = 0;
my $myname = 'clonie';
my $myversion = '0.0.2';
my $executerlogfile = "/var/log/$myname.log";
my $tmpfile = "/tmp/$myname.tmp";
my $clonesnap = 'cloniesnap';
my $d_etc = '/etc';
my $f_rc_conf = "$d_etc/rc.conf";


my $cloner_backtitleheader = "$myname v$myversion";

if ($> != 0) {
    die "This program must be run as root!\n";
}

sub logconsole
{
    my $t = shift;
    
    print $t;
    open my $file, '>>', $executerlogfile or die;
    print $file $t or die;
    close $file or die;
}

# string read_a_file( string filename)
# returns a reference to the text
sub read_a_file
{
    my $fn = shift;
    local $/ = undef;
    open FILE, $fn or return undef;
    my $text = <FILE>;
    close FILE or return undef;
    return \$text;
}

# int xwrite_a_file( string filename, stringref text, mode {write|append})
sub xwrite_a_file
{
    my $fn = shift;
    my $tx = shift;
    my $m = shift;
    my $mode;
    if ($m eq 'write') {
        $mode = '>';
    } elsif ($m eq 'append') {
        $mode = '>>';
    } else {
        die "'$m'";
    }
    open my $file, $mode, $fn or return -1;
    print $file $$tx or return -2;
    close $file or return -3;
    return 0;
}

# int append_a_file( string filename, stringref text)
sub append_a_file
{
    my $fn = shift;
    my $tx = shift;
    logconsole( "append_a_file( $fn)\n");
    return xwrite_a_file( $fn, $tx, 'append');
}

# int write_a_file( string filename, stringref text)
sub write_a_file
{
    my $fn = shift;
    my $tx = shift;
    logconsole( "write_a_file( $fn)\n");
    return xwrite_a_file( $fn, $tx, 'write');
}

############################################################    
####################    utility functions for "internal commands"
############################################################
     
sub callsystem
{
    my $sy = shift;
    
    logconsole( "callsystem('$sy')\n");
    my $syr = system( $sy);
    if ($syr == -1) {
        # error
        my $syserrno;
        my $syserrstr;
        if ($syserrno = $!) {
            $syserrstr = "$!";
            logconsole( "callsystem: failed with error number $syserrno ($syserrstr)\n");
            die;
        }
        my $sysstatus = $?;
        if ($sysstatus & 127) {
            my $m .= "callsystem: died with signal " . ($sysstatus & 127);
            if ($sysstatus & 128) {
                $m .= ' and dumped core';
            }
            logconsole( " $m\n");
            die;
        }
    }
    my $retc = $syr >> 8;
    logconsole( 'callsystem: returned \'' . $retc . "'. Success\n");
    return $retc;
}

sub yesno
{
    my $backtitle = shift;
    my $title = shift;
    my $text = shift;
    my $dimensions = shift; #  string "height width"

    my $sy = "dialog --backtitle '$backtitle' --title '$title' --clear --yesno '$text' $dimensions";
    my $r = callsystem( $sy);

# TODO find out what is wrong!
# logconsole( "yesno: dialog returned '$r'\n");
# sometimes dialog-yesno returns 2 (Help) instead of 0 (OK) ?!?
if ($r == 2) {
    $r = 0;
}

    return (($r) ? 0 : 1);
}

sub msgbox
{
    my $backtitle = shift;
    my $title = shift;
    my $text = shift;
    my $dimensions = shift; #  string "height width"

    my $sy = "dialog --backtitle '$backtitle' --title '$title' --clear --msgbox '$text' $dimensions";

    callsystem( $sy);
}

sub getcheckform
{
    my $itemlist = shift;   # ref hash (id => description text)
    my $itemseq = shift;    # ref list (sequence items are to be listed)
    my $backtitle = shift;
    my $title = shift;
    my $checklisttext = shift;
    my $dimensions = shift; #  string "formheight formwidth listheight"
    my $selections = shift; # ref hash filled on return (selected ids exist as keys)
    my $itemenable = shift; # optional: undef or ref hash (id => on|off)
    my $defaultonoff = shift; # optional: undef or either string on|off
    
    
    my $sy = "dialog --backtitle '$backtitle' --title '$title' --clear --checklist '$checklisttext' $dimensions";
    
    foreach (@{$itemseq}) {
        # %itemlist items need not to be in @itemseq,
        # because @itemseq serves as general sequence definition
        if (exists ${$itemlist}{$_}) {
            if (defined $itemenable) {
                $sy .= " $_ '${$itemlist}{$_}' ${$itemenable}{$_}";
            } elsif (defined $defaultonoff) {
                $sy .= " $_ '${$itemlist}{$_}' $defaultonoff";
            } else {
                $sy .= " $_ '${$itemlist}{$_}' off";
            }
        }
    }
    $sy .= " 2>$tmpfile";
    
    my $r = callsystem( $sy);
    die "Exited by pressing \"ESC\"\n" if ($r == 255);
    die "Exited by selecting \"Cancel\"\n" if ($r == 1);
    die "Exited because of unknown dialog return code '$r'\n" if ($r);

    my $rref = read_a_file( $tmpfile);
    unlink( $tmpfile);
    {
        my @selitems = split( ' ', $$rref);
        foreach (@selitems) {
            ${$selections}{ $_} = 'i';
        }
    }
}


sub getradioform
{
    my $itemlist = shift;   # ref hash (id => description text)
    my $itemseq = shift;    # ref list (sequence items are to be listed)
    my $backtitle = shift;
    my $title = shift;
    my $radiolisttext = shift;
    my $dimensions = shift; #  string "formheight formwidth listheight"
    my $selection = shift;  # ref string filled on return (selected tag)
    my $itemdefault = shift; # optional: ref str with the item tag to be activated by default
    
    my $sy = "dialog --backtitle '$backtitle' --title '$title' --clear --radiolist '$radiolisttext' $dimensions";
    
    my $firstdone = 0;
    foreach (@{$itemseq}) {
        # %itemlist items need not to be in @itemseq,
        # because @itemseq serves as general sequence definition
        if (exists ${$itemlist}{$_}) {
            my $onoff;
            if (defined $itemdefault) {
                $onoff = ($_ eq $$itemdefault)
                            ? 'on'
                            : 'off';
            } else {
                if (not $firstdone) {
                    $onoff = 'on';
                    $firstdone = 1;
                } else {
                    $onoff = 'off';
                }
            }
            $sy .= " $_ '${$itemlist}{$_}' $onoff";
        }
    }
    $sy .= " 2>$tmpfile";
    
    my $r = callsystem( $sy);
    die "Exited by pressing \"ESC\"\n" if ($r == 255);
    die "Exited by selecting \"Cancel\"\n" if ($r == 1);
    die "Exited because of unknown dialog return code '$r'\n" if ($r);

    my $rref = read_a_file( $tmpfile);
    unlink( $tmpfile);
    $$selection = $$rref;
}

sub getdataform
{
    my $itemlist = shift;   # ref hash (id => description text)
    my $itemseq = shift;    # ref list (sequence items are to be listed)
    my $backtitle = shift;
    my $title = shift;
    my $formtext = shift;
    my $dimensions = shift; #  string "height width formheight"
    my $fields = shift;     # ref hash, keys as in itemlist/itemseq, valueseither undef, empty or preset strings, on return filled with user entries
    my $labelpos = shift; # ref hash, each value:
    #     y x               > y x positions where keys (field labels) are placed
    my $fieldposdim = shift; # ref hash, each value:
    #     y x flen ilen     > y x positions where field are placed
    #                       > flen : screen field length
    #                       > ilen : data field length (scrolls in line if longer than flen)
    
    my $sy = "dialog --backtitle '$backtitle' --title '$title' --clear --form '$formtext' $dimensions";
    foreach (@{$itemseq}) {
        # %itemlist items need not to be in @itemseq,
        # because @itemseq serves as general sequence definition
        if (exists ${$itemlist}{$_}) {
            my $f = (exists ${$fields}{$_})
                        ? ${$fields}{$_}
                        : '';
            $sy .= " '${$itemlist}{$_}' ${$labelpos}{$_} '$f' ${$fieldposdim}{$_}";
        }
    }
    $sy .= " 2>$tmpfile";

    my $r = callsystem( $sy);
    die "Exited by pressing \"ESC\"\n" if ($r == 255);
    die "Exited by selecting \"Cancel\"\n" if ($r == 1);
    die "Exited because of unknown dialog return code '$r'\n" if ($r);
    
    my $rref = read_a_file( $tmpfile);
    unlink( $tmpfile);
    my @flds = split( "\n", $$rref);
    foreach (@{$itemseq}) {
        if (exists ${$itemlist}{$_}) {
            ${$fields}{$_} = shift @flds;
        }
    }
}




#########################################
######################################### here getmyip stuff start 
#########################################

sub iptonum
{
    my $ip = lc shift;
    my $ipn;

    # check the format 
    if ($ip =~ /^0x/) {
        $ip =~ s/0x//;
        $ipn = hex $ip;
    } else {
        return( undef) unless ($ip =~/([01-9a-f\.]{1,3})\.([01-9a-f\.]{1,3})\.([01-9a-f\.]{1,3})\.([01-9a-f\.]{1,3})/);
        $ipn = $4 + $3 * 256 + $2 * 65536 + $1 * 16777216;
    }

    return $ipn;
}

# take a netmask in dot notation and return its bits
# note that it is somewhat "buggy" and just counts ones, 
# does not catch the invalid case if there are zeroes 
# embedded in the 1 stream TODO fix this
sub netmasktobits
{
    my $nm = lc shift;

    my $nmn = iptonum( $nm);
    my $s = sprintf( "%#b", $nmn);
#     my $d = () = $s =~ /\Q1/g;
    my $d = length( $s =~ s/[^\Q1\E]//rg );

    return $d;
}

sub andipwithnetmask
{
    my $ip = shift;
    my $nm = shift;
    
    my $i = $nm;
    my $nmn = 1;
    do {
        if (--$i) {
            $nmn <<= 1;
            $nmn += 1;
        }
    } while ($i);
    $nmn <<= 32 - $nm;
    $nmn &= 0xffffffff; # snip overflow
    return $ip & $nmn;
}

sub getmyip
{
    my %ifip;
    my %ifnm;
    my %ifact;
    my %ifonl;
    my %ifdhcp;
    my $defaultrouter;

    my %ifconfig;
    
    # look at predefined gateway IP if exists
    my $tmps = read_a_file( $f_rc_conf);
    ($defaultrouter) = $$tmps =~ /defaultrouter\=\"([01-9\.]+)\"/;
    if (defined $defaultrouter) {
        $defaultrouter = iptonum( $defaultrouter);
    }
    my (@ifc) = $$tmps =~ /^ifconfig_\w+\d+=".*?"$/msg;
    foreach (@ifc) {
        my ($if, $conf) = /^ifconfig_(\w+\d+)="(.*?)"$/;
        $ifconfig{$if} = $conf;
        unless ($conf =~ /DHCP/i) {
            (my $ip) = $conf =~ /inet\s([01-9\.]+)/;
            if (defined $ip) {
                $ifip{$if} = iptonum( $ip);
            }
            (my $nm) = $conf =~ /netmask\s([01-9\.]+)/;
            if (defined $nm) {
                $ifnm{$if} = netmasktobits( $nm);
            };
        } else {
            $ifdhcp{$_} = 'YES';
        }
    }

    # get active ifconfig
    $tmps = `ifconfig`;
    my @ifln = split( "\n", $tmps);
    my $intf = '';
    foreach (@ifln) {
        # does line begin with interfaceNN: ?  or with blanks?
        if (/^(\w+\d+)\:\s(.*)$/) {
            $intf = $1;
            # new interface, zero all data from previous loops
            my $ln = $2;   # seems always to have flags
            # is this intf UP and RUNNING?
            my $isrunning = ($ln =~ /RUNNING/) ? 1 : 0;
            $ifact{$intf} = (($ln =~ /UP/) and $isrunning )
                        ? 1 
                        : 0;
        } else {
            # right now we only care for the IP and the Status Active/Associated
            if (/status:\s/) {
                my $isonl = (/status:\s(?:active|associated)/)
                        ? 1 
                        : 0;
                $ifonl{$intf} = $isonl;
            }
            # safety check if other stuff is in line with the rc.conf data
            if (/inet:\s([01-9\.]+)/) {
                if (exists $ifip{$intf}) {
                    if ($ifip{$intf} ne iptonum( $1)) {
                        return "Impossible - ip wrong?";
                    }
                } else {
                    $ifip{$intf} = iptonum( $1);
                }
            }
            
            if (/netmask\s([01-9a-fx\.]+)/) {
                my $nm = netmasktobits( $1);
                if (exists $ifnm{$intf}) {
                    if ($ifnm{$intf} ne $nm) {
                        return "Impossible - nm wrong?";
                    }
                } else {
                    $ifnm{$intf} = $nm;
                }
            }
        }
    }
    
    # counter-check with netstat that defaultrouter in rc.conf is correct
    # or in case of DHCP, add defaultrouter
    my $ns = `netstat -rn -4`;
    my ($nsdrip, $nsdrif) = $ns =~ /^default\s+([01-9\.]+)\s+\w+\s+(\w+\d+)$/ms;
    return "no internet connection!" unless (defined $nsdrip and defined $nsdrif);
    $nsdrip = iptonum( $nsdrip);
    if (defined $defaultrouter) {
        return "netstat-rc.conf mismatch" if ($nsdrip != $defaultrouter);
    } else {
        $defaultrouter = $nsdrip;
    }
    
    # walk through all interfaces and check which
    # or match the ip/netmask with defaultrouter
    my $ifuplink;
    foreach (keys %ifact) {
        next if (/^lo\d+/);
        next if (not exists $ifip{$_});
        next if (not exists $ifonl{$_});
        
        if (andipwithnetmask( $ifip{$_}, $ifnm{$_}) == 
                    andipwithnetmask( $defaultrouter, $ifnm{$_})) {
            $ifuplink = $_;
            last;
        }
    }
    
    unless (defined $ifuplink) {
        return "no internet 'uplink' connection found" if ($nsdrip != $defaultrouter);
    }
    my $dhcp = (exists $ifdhcp{$ifuplink})
        ? 1
        : 0;
    my $isonl = (exists $ifonl{ $ifuplink})
        ? 1
        : 0;
    return ($ifuplink, $ifip{ $ifuplink}, $ifnm{ $ifuplink}, $ifonl{ $ifuplink}, $dhcp, $defaultrouter);
}

# return dot string from a numerical IP/netmask
sub getdotipstr
{
    my $ip = shift;
    
    my $d1 = int ($ip / 16777216);
    my $ipx = $ip % 16777216;
    my $d2 = int ($ipx / 65536);
    $ipx %= 65536;
    my $d3 = int ($ipx / 256);
    $ipx %= 256;
    
    return "$d1.$d2.$d3.$ipx";
}

sub getdotnetmaskstr
{
    my $nmb = shift;
    my $i = $nmb;
    my $nmn = 1;
    do {
        if (--$i) {
            $nmn <<= 1;
            $nmn += 1;
        }
    } while ($i);
    $nmn <<= 32 - $nmb;
    $nmn &= 0xffffffff; # snip overflow
    return getdotipstr( $nmn);

}



#########################################
######################################### here getmyip stuff end
#########################################


#########################################
######################################### here sysmod stuff start
#########################################

sub escapeme
{
    my $str = shift;
    $str =~ s/\\/\\\\/;
    $str =~ s/\|/\\\|/;
    $str =~ s/\[/\\\[/;
    $str =~ s/\]/\\\]/;
    $str =~ s/\{/\\\{/;
    $str =~ s/\}/\\\}/;
    $str =~ s/\(/\\\(/;
    $str =~ s/\)/\\\)/;
    $str =~ s/\</\\\</;
    $str =~ s/\>/\\\>/;
    $str =~ s/\*/\\\*/;
    $str =~ s/\./\\\./;
    $str =~ s/\?/\\\?/;
    $str =~ s/\+/\\\+/;
    $str =~ s/\^/\\\^/;
    $str =~ s/\$/\\\$/;
    return $str;
}

my $sysmod = '_sysmod_';

# sub sysmod - replacement for useless sysrc
# see TODO PR link
sub sysmod
{
    my $filename = shift;
    my $expr = shift;
    my $oper = 'replace';
    my $parenchar = shift;
    my $sep = ' ';
    my $file;
    
    # remove surrounding apostrophes if present
    foreach ( '\'', '"') {
        if ($expr =~ /^$_.*$_$/) {
            substr( $expr, length($expr) - 1, 1, "");
            substr( $expr, 0, 1, "");
        }
    }
    
    $file = read_a_file( $filename);
    if (not defined $file) {
        # file does not exist yet
        my $ph = '';
        $file = \$ph;
    }
    
    if ($parenchar eq 'delete') {
        (my $left, my $right) = $expr =~ /^(.*)=.*$/;
        die if (not defined $left);
        my $left_esc = escapeme($left);
        my $subst = $$file =~ s/^\s*$left_esc\s*=.*$//s;
        if ($subst) {
            die if (write_a_file( $filename, $file));
            logconsole( "sysmod: written changed file '$filename' with deleted '$expr'\n");
        } else {
            logconsole( "sysmod: not written file '$filename' because nothing changed, '$expr' to be deleted did not exist\n");
        }
        return;
    }
    
    (my $left, my $right) = $expr =~ /^(.*)=(.*)$/;
    die if (not defined $left or not defined $right);
    if ($left =~ /\+$/) {
        $oper = 'add';
        chop $left;
    } elsif ($left =~ /\-$/) {
        $oper = 'remove';
        chop $left;
    }
    
    if (($right =~ /^".*"$/) or ($right =~ /^'.*'$/)) {
        # $right is in parens
        substr( $right, length($right) - 1, 1, "");
        substr( $right, 0, 1, "");
    }
    
    if ($oper eq 'add' or $oper eq 'remove') {
        # if delimiter present, remove it
        if (length($right)) {
            if (not ($right =~ /^[a-zA-Z1-90]/)) {
                $sep = substr( $right, 0, 1);
                substr( $right, 0, 1, "");
            }
        }
    }
    
    my $lv;
    my $rv;
    my $prematch;
    my $postmatch;
    my $changed = 0;
    my $left_esc = escapeme($left);
    my $right_esc = escapeme($right);
    
    # check whether value is already present
    if ($$file =~ /(?:\n|^)\s*$left_esc(?:[^\n]*)(?:\n|$)/s) {
        ($prematch, $lv, $rv, $postmatch) = $$file =~ /^(.*(?:\n*))((?:\s*$left_esc\s*))=([^\n]*)(.*)$/s;
    }
    if ($parenchar ne '' and defined $rv and $rv =~ /^$parenchar.*$parenchar$/) {
        # remove parens from $rv
        substr( $rv, length($rv) - 1, 1, "");
        substr( $rv, 0, 1, "");
    }
    
    if ($oper eq 'remove') {
        my $recompose = 1;
        if (not defined $lv) {
            # lv not present, nothing to do
            # check whether rvalue already contains $right
        } elsif ($rv =~ /^(?:.*$sep\s*|)$right_esc(?:\s*$sep.*|\s+|$)/) {
            $changed = 1;
            # left present, contains right, remove right from rv
            # four cases:
            # 1. rv is only value -> remove both lv and rv
            # 2. rv is last value -> remove rv and previous delim
            # 3. rv is first value -> remove rv and first delim
            # 4. rv is middle value -> remove rv and one delim
            if ($rv =~ /^\s*$right_esc\s*$/) {
                # 1. rv is only value -> remove both lv and rv
                # make sure only one CR remains
                if (length( $postmatch)) {
                    substr( $postmatch, 0, 1, "");
                } elsif ($prematch =~ /\n$/) {
                    chomp $prematch;
                }
                $$file = $prematch . $postmatch;
                $recompose = 0;
            } elsif ($rv =~ /.*$sep\s*$right_esc\s*$/) {
                # 2. rv is last value -> remove rv and previous delim
                (my $snip) = $rv =~ /.*($sep\s*$right_esc\s*).*/;
                $rv =~ s/$snip//;
            } elsif ($rv =~ /^\s*$right_esc\s*$sep/) {
                # 3. rv is first value -> remove rv and first delim
                (my $snip) = $rv =~ /.*($right_esc\s*$sep\s*).*/;
                $rv =~ s/$snip//;
            } elsif ($rv =~ /.*$sep\s*$right_esc\s*$sep\s*.*/) {
                # 4. rv is middle value -> remove rv and one delim
                (my $snip) = $rv =~ /.*($sep\s*$right_esc\s*)$sep\s*.*/;
                $rv =~ s/$snip//;
            } else {
                die;   # should never happen
            }
        } else {
            # left present, does not contain right, nothing to do
        }
        if ($changed and $recompose) {
            $$file = $prematch . $lv . '=' . $parenchar . $rv . $parenchar . $postmatch;
        }
    } elsif ($oper eq 'add') {
        if (not defined $lv) {
            # lv not present, just add left=right
            if (not $$file =~ /\n$/) {
                $$file .= "\n";
            }
            $$file .= $left . '=' . $parenchar . $right . $parenchar . "\n";
            $changed = 1;
            # check whether rvalue already contains $right
        } elsif ($rv =~ /(?:.*$sep\s*|)$right_esc(?:\s*$sep.*|\s*)/) {
            # left present, contains right, nothing to do
            $changed = 0;
        } else {
            # left present, does not contain right, add right
            my $ins = '';
            if ($prematch =~ /^\n/) {
                $ins = "\n";
            }
            $rv =~ s/\n$//s;    # chop newline if present
            $rv =~ s/\s*$//s;   # chop whitespace if present
            $ins .= $left . '=' . $parenchar . $rv . $sep . $right . $parenchar;
            $$file = $prematch . $ins . $postmatch;
            $changed = 1;
        }
    } elsif ($oper eq 'replace') {
        # make sure it is not present yet
        if (not defined $lv) {
            # lv not present, just add
            if (not $$file =~ /\n$/) {
                $$file .= "\n";
            }
            $$file .= $left . '=' . $parenchar . $right . $parenchar . "\n";
            $changed = 1;
        } else {
            # left present, replace if rv and right not equal
            if ($right ne $rv) {
                $$file = $prematch . $left . '=' . $parenchar . $right . $parenchar . $postmatch;
                $changed = 1;
            }
        }
    }
    
    if ($changed) {
        die if (write_a_file( $filename, $file));
        logconsole( "sysmod: written changed file '$filename' with settings '$expr'\n");
    } else {
        logconsole( "sysmod: not written file '$filename' because nothing changed by settings '$expr'\n");
    }
}

sub isnumin {
  my $aref = shift;
  my $num = shift;
  my $isin = 0;
  foreach (@$aref) {
    next if ($_ == $num);
    $isin = 1;
  }
  return $isin;
}

sub executer
{
    my $batch = shift;
    my @steps = split( "\n", $batch);
    
    
#     print "================== BATCH START\n$batch\n================== BATCH END\nconfirm or abort:\n";
#     
#     <STDIN>;
    
    
    logconsole( "executer start\n");
    foreach (@steps) {
        # check for cd, do these commands ourself
        if (/^cd\s/ or /^chdir\s/) {
            if (/^cd\s([a-zA-Z1-9_\-\/]+)$/ or /^chdir\s([a-zA-Z1-9_\-\/]+)$/) {
                my $newdir = $1;
                if (not chdir( $newdir)) {
                    die "executer: Dir doesn't exist!" 
                }
                next;
            } else {
                die "executer: Bad chdir";
            }
        } elsif (/^$sysmod/) {
            (my $fil, my $arg, my $paren) = $_ =~ /^$sysmod\s+([^\s]*)\s+(.*?)\s+(none|single|double|delete)\s*$/;
            my $parch;
            if ($paren eq 'single') {
                $parch = '\'';
            } elsif ($paren eq 'double') {
                $parch = '"';
            } elsif ($paren eq 'none') {
                $parch = '';
            } elsif ($paren eq 'delete') {
                $parch = 'delete';
            } else {
                die "bad paren\n";
            }
            sysmod( $fil, $arg, $parch);
            next;
        }
        
        # check if special "pass on" return codes are defined
        # these are given in the format:
        #   [a b c]command parms
        # makes executer interpret a b c as success return codes
        # for example freebsd-update install returns 1/2 if system is up-to-date!
        my $ex;
        my @goodcodes;
        my $isspecial;
        if (/^\[([01-9 ]+)\](.*)$/) {
            $ex = $2;
            @goodcodes = split( '\s', $1);
            $isspecial = 1;
        } else {
            $ex = $_;
            $isspecial = 0;
        }
        
        my $retval = 0;
        $retval = callsystem($ex);
        if ($isspecial) {
            if ( isnumin( \@goodcodes, $retval)) {
                logconsole( "executer: Success! retval $retval: '$_'\n");
                next;
            }
        } else {
            if ($retval == 0) {
                logconsole( "executer: Success! retval $retval: '$_'\n");
                next;
            }
        }
        # error out
        logconsole( "executer: Terminated: Got nonzero result from '$_'\n");
        die;
    }
    logconsole( "executer finish\n");
}

#########################################
######################################### from here the actual cloner stuff
#########################################




sub getzpoolstatus
{
    my $gzs = `zpool status`;
    return $gzs;
}

sub getzfslist
{
    my $gzl = `zfs list -H`;
    return $gzl;
}

sub getzfslistsnap
{
    my $gzl = `zfs list -H -t snapshot`;
    return $gzl;
}

sub getdmesgboot
{
    my $dmb = read_a_file( '/var/run/dmesg.boot');
    return $$dmb;
}

sub getgpartshow
{
    my $drv = shift;
    if (not defined $drv) {
        $drv = '';
    } else {
        $drv = " $drv";
    }
    my $gps = `gpart show$drv`;
    return $gps;
}

sub getvarlogmess
{
    my $vlm = read_a_file( '/var/log/messages');
    return $$vlm;
}

sub getgeom
{
    my $geom = `geom disk list`;
    return $geom;
}

sub getmount
{
    my $mou = `mount`;
    return $mou;
}

sub getzpoolgetbootpool
{
    my $zpogebo = `zpool get -H bootfs`;
    return $zpogebo;
}

sub getdirdatetag
{
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
	my $now = sprintf("%04d-%02d-%02d-%02d:%02d:%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec);
	return $now;
}

sub tobytes
{
    my $s = shift;

    my %mult = (
        'B' => 1,
        'K' => 1024,
        'M' => 1048576,
        'G' => 1073741824,
        'T' => 1099511627776,
    );
    my ($base, $expon) = $s =~ /^([01-9.]+)([BKMGT]+)$/;
    my $n = sprintf("%.0f", $base * $mult{$expon});
    return $n;
}

sub bytesto
{
    my $s = shift;
    my $r;
    if ($s >= 1099511627776) {
        $r = sprintf("%.1fT", $s / 1099511627776);
    } elsif ($s >= 1073741824) {
        $r = sprintf("%.1fG", $s / 1073741824);
    } elsif ($s >= 1048576) {
        $r = sprintf("%.1fM", $s / 1048576);
    } elsif ($s >= 1024) {
        $r = sprintf("%.1fK", $s / 1024);
    } else {
        $r = $s . 'B';
    }
    return $r;
}

sub bytestodec
{
    my $s = shift;
    my $r;
    if ($s >= 1099511627776) {
        $r = sprintf("%.1fT", $s / 1000000000000);
    } elsif ($s >= 1073741824) {
        $r = sprintf("%.1fG", $s / 1000000000);
    } elsif ($s >= 1048576) {
        $r = sprintf("%.1fM", $s / 1000000);
    } elsif ($s >= 1024) {
        $r = sprintf("%.1fK", $s / 1000);
    } else {
        $r = $s . 'B';
    }
    return $r;
}


# # what we need to find out
# my $mach_bootpool;
# my @mach_emptydrives;

# find drives
# get actual drives
# drive device => drive name/type
my %drvs_type = ();
my %drvs_serial = ();
my %drvs_extrainfo = ();
my %drvs_size = ();
my %drvs_umass = ();

my $drive;
my $geom = getgeom();
my @geoms = split("\n\n", $geom);
foreach (@geoms) {
    next unless (/^Geom name:\s(a?da\d+)/);
    my ($drivename) = /^Geom name:\s(a?da\d+)/;
    my (@g) = /^\s{3}(.*?):\s(.*?)$/mg;
    while (@g) {
        my $v = pop @g;
        my $k = pop @g;
        ${$drive}{$drivename}{$k} = $v;
    }
}

# now find out drives listed in gpart show
# so we know which ones are partitioned, or empty/dangerously dedicated
{
    my $gpartshow = getgpartshow();
    my (@gpart_drvs) = $gpartshow =~ /^=>\s+\d+\s+\d+\s+(a?da\d+\s+\w+)/msg;
    if ( @gpart_drvs) {
        foreach (@gpart_drvs) {
            my ($drv, $part) = /(a?da\d+)\s+(\w+)/;
            ${$drive}{$drv}{'partitioned'} = $part;
        }
    }
    my @gpartlines = split( "\n", $gpartshow);
    my $skip = 0;
    my $thisdrv;
    foreach (@gpartlines) {
        my ($gpart_drv) = /^=>\s+\d+\s+\d+\s+(a?da\d+)\s+.*?$/;
        if (defined $gpart_drv) {
            $skip = (exists ${$drive}{$gpart_drv})
                    ? 0
                    : 1;
            $thisdrv = $gpart_drv;
            next;
        } elsif ($skip) {
            $skip = 0;
            next;
        }
        next unless (defined $thisdrv);
        # find following things:
        # - has "freebsd-boot"
        # - has "freebsd-zfs"
        # - has grub kaka "bios-boot" - refuse to clone
        # - has "efi"
        # ignore other partition types for now
        my ($partno, $parttyp, $partsize) = /^\s+\d+\s+\d+\s+(\d)\s+([a-z01-9-]+)\s+\(([01-9.BKMGT]+)\)$/;
        if (defined $parttyp and $parttyp =~ /freebsd-boot|freebsd-zfs|bios-boot|efi/) {
            ${$drive}{$thisdrv}{'partition'}{$partno}{'type'} = $parttyp;
            ${$drive}{$thisdrv}{'partition'}{$partno}{'size'} = $partsize;
            if ($parttyp =~ /freebsd-boot|bios-boot|efi/) {
                ${$drive}{$thisdrv}{'boottypes'}{$parttyp} = 'YES';
            }
        } else {
            my ($freespace) = /^\s+\d+\s+\d+\s+-\sfree\s-\s+\(([01-9.BKMGT]+)\)$/;
            if (defined $freespace) {
                # and find the biggest "- free -" partition
                my $bytes = tobytes( $freespace);
                if (exists ${$drive}{$thisdrv}{'freespace'}) {
                    if (${$drive}{$thisdrv}{'freespace'} < $bytes) {
                        ${$drive}{$thisdrv}{'freespace'} = $bytes;
                    }
                } else {
                    ${$drive}{$thisdrv}{'freespace'} = $bytes;
                }
            }
        }
    }
}

# for the unpartitioned drives take mediasize
foreach (keys %{$drive}) {
    if (${$drive}{$_}{'partitioned'} and
                not defined ${$drive}{$_}{'freespace'}) {
        # not all drives have free space, so add that variable
        ${$drive}{$_}{'freespace'} = 0;
    }
    my ($size, $sizeE) = ${$drive}{$_}{'Mediasize'} =~ /^(\d+)\s\(([01-9.BKMGT]+)\)$/;
    
    # calculate sizeE, because that one in Mediasize is only 1 digit after decimal pt?!?
    ${$drive}{$_}{'mediasize'} = $size;
    ${$drive}{$_}{'mediasizeE'} = bytesto( $size);
    
    if (exists ${$drive}{$_}{'partitioned'}) {
        ${$drive}{$_}{'freespaceE'} = 
                    bytesto(${$drive}{$_}{'freespace'});
    } else {
        ${$drive}{$_}{'freespace'} = $size;
        ${$drive}{$_}{'freespaceE'} = $sizeE;
    }
}

my $hostname;
$hostname = `hostname`;
chomp $hostname;
# now get the umass thingies identified as such
my $varlome = getvarlogmess();
# snip out all before last boot
# that is, if there is a boot message
if ($varlome =~ /^
                    \w{3}               # Mon
                    \s{1,2}\d{1,2}\s    # Day
                    \d{2}:              # hh:
                    \d{2}:              # mm:
                    \d{2}\s             # ss
                    $hostname\s
                    kernel:\s
                    ---<<BOOT>>---$
                    /smx) {
    $varlome =~ s/^.*
                \w{3}               # Mon
                \s{1,2}\d{1,2}\s    # Day
                \d{2}:              # hh:
                \d{2}:              # mm:
                \d{2}\s             # ss
                $hostname\s
                kernel:\s
                ---<<BOOT>>---
                \n
                //sx;
}
# Throw out any non-kernel messages and other garbage
$varlome =~ s/^
            \w{3}               # Mon
            \s{1,2}\d{1,2}\s    # Day
            \d{2}:              # hh:
            \d{2}:              # mm:
            \d{2}\s             # ss
            $hostname\s
            kernel:\s
            (.*)$
            /$1/mgx;

# Throw out any non-daX messages
# and get all USB drives
my @varlomea = split( "\n", $varlome);
$varlome = '';
foreach (@varlomea) {
    if (/^(da\d+)\sat\sumass.*?$/) {
        next unless (defined $1);
        if (exists ${$drive}{$1}) {
            ${$drive}{$1}{'USB'} = 'YES';
        }
        $varlome .= $_ . "\n";
    }
}

# now find out whats the boot dataset and the bootpool
my $mnt = getmount();
my ($bootdataset) = $mnt =~ /^((?:\w|\/)+)\son\s\/\s\(zfs/sm;
my ($bootpool) = $bootdataset =~ /^([^\/]+)/;

# double check and find out, is it local
my $zpogebo = getzpoolgetbootpool();
chomp $zpogebo;

my ($bootablepool, $bootfs, $bootsrc) = $zpogebo =~ /^(\w+)\s+bootfs\s+((?:\w|\/)+)\s+(\w+)/;

die if ($bootdataset ne $bootfs or $bootpool ne $bootablepool);

my $zfspools;
${$zfspools}{$bootpool}{'bootpool'} = 'YES';
${$zfspools}{$bootpool}{'bootfs'} = $bootfs;

# now find out drives carrying mounted boot zpool

# as we cannot clone the system to these drives
my $zps = getzpoolstatus();
# leave only interesting lines
$zps =~ s/^......:.*?$//msg;


my @zpsl = split( "\n", $zps);
my $thepool;
my $pooltypetag = 0;
foreach (@zpsl) {
    if (/^\s+NAME\s+STATE\s+READ\s+WRITE\s+CKSUM\s*?$/ or
                /^\s*?$/) {
        $thepool = undef;
        next;
    }
    unless (defined $thepool) {
        ($thepool, my $line) = /^\s+(\w+)\s+(\w+).*?$/;
        die unless (defined $thepool and defined $line);
        # check marker: next line should describe the pool type
        # if it has no pool type, it is probably stripe 
        # without redundancy
        $pooltypetag = 1;
        next;
    }
    my ($dev, $part) = /^\s+(a?da\d+)[sp](\d)\s+.*?$/;
    unless (defined $dev and defined $part) {
        my ($pooltype, $poolnumber) = /^\s+([a-z01-9]+)-(\d+)\s+.*?$/;
        ${$zfspools}{$thepool}{'pooltype'} = $pooltype;
        ${$zfspools}{$thepool}{'poolnumber'} = $poolnumber;
        $pooltypetag = 0;
        next;
    }
    if ($pooltypetag) {
        # zpool status showed no pool raid type
        # so we can assume it is stripe
        ${$zfspools}{$thepool}{'pooltype'} = 'stripe';
        $pooltypetag = 0;
    }
    if ($thepool eq $bootpool) {
        ${$drive}{$dev}{'bootpool'} = $part;
        ${$drive}{$dev}{'bootpoolname'} = $thepool;
    } else {
        ${$drive}{$dev}{'nonbootpool'}{$part} = $thepool;
    }
    ${$zfspools}{$thepool}{'drives'}{$dev} = $part;
    ${$drive}{$dev}{'pools'}{$thepool} = $part;
}

# get used/avail space on pools
# and again verify bootpool, like when checking mounts
my $zfslist = getzfslist();
# NAME                      USED  AVAIL  REFER  MOUNTPOINT
foreach (keys %$zfspools) {
    my ($used, $avail, $refer, $mp) = $zfslist =~ /^$_\s+([01-9.BKMGT]+)\s+([01-9.BKMGT]+)\s+([01-9.BKMGT]+)\s+(.*?)$/sm;
    if (defined $used and defined $avail and defined $refer and defined $mp) {
        ${$zfspools}{$_}{'usedE'} = $used;
        ${$zfspools}{$_}{'availE'} = $avail;
        ${$zfspools}{$_}{'referE'} = $refer;
        ${$zfspools}{$_}{'used'} = tobytes($used);
        ${$zfspools}{$_}{'avail'} = tobytes($avail);
        ${$zfspools}{$_}{'refer'} = tobytes($refer);
    
    } else {
        die "Info on pool '$_' could not be found\n";
    }
    my ($bopo) = $zfslist =~ /^($_\w+\s+[01-9.BKMGT]+)\s+[01-9.BKMGT]+\s+[01-9.BKMGT]+\s+\/$/;
    if (defined $bopo) {
        if (${$zfspools}{$bootpool}{'bootfs'}) {
        
        } else {
            die "Info on / mount on '$_' could not be found\n";
        }
    }
}

my $bps = '';
my $dps = '';
my $smallest_boot = 0;
my $smallest_nonboot = 0;
# offer the user a list of clonable pools
foreach (keys %$zfspools) {

    # minimum data size for a sensibly clonable pool?
    # 10MB?
    my $mindatasize = 10000000;
    
    next if (${$zfspools}{$_}{'used'} < $mindatasize);

    # get nicely formatted info strings on every clonable pool
    my $i = (exists ${$zfspools}{$bootpool})
            ? "Boot p"
            : "P";
    $i .= "ool name: $_\n";
    
    $i .= "Pool used space: ${$zfspools}{$_}{'usedE'}\n";
    
    
    if (exists ${$zfspools}{$bootpool}) {
        $bps .= $i;
        if ($smallest_boot == 0 or $smallest_boot > ${$zfspools}{$_}{'used'}) {
            $smallest_boot = ${$zfspools}{$_}{'used'};
        }
    } else {
        $dps .= $i;
        if ($smallest_nonboot == 0 or $smallest_nonboot > ${$zfspools}{$_}{'used'}) {
            $smallest_nonboot = ${$zfspools}{$_}{'used'};
        }
    }
}

# find out which drives are not mounted
# and thus possibly can be erased
my (@mounted) = $mnt =~ /^\/dev\/(a?da\d+).*?$/smg;
if (@mounted) {
    foreach (@mounted) {
        ${$drive}{$_}{'mounted'} = 'YES';
    }
}


# consider every drive that is not mounted and has no active pool 
# as potential erasing candidate
my @erasecandidates;
foreach (sort keys %$drive) {
    if ( not exists ${$drive}{$_}{'mounted'} and 
            not exists ${$drive}{$_}{'pools'} ) {
        push @erasecandidates, $_;
    }
}

my %erasedrives;
if (@erasecandidates) {
    # ask user whether to erase and use these drives:
    my %eraselist;
    foreach (@erasecandidates) {
        my $d = '';
        $d .= ${$drive}{$_}{'mediasizeE'} . 'B ';
        if (exists ${$drive}{$_}{'partitioned'}) {
            $d .= 'partitioned (' . ${$drive}{$_}{'partitioned'} . ') ';
        } else {
            $d .= 'unpartitioned ';
        }
        if (${$drive}{$_}{'rotationrate'} eq '0') {
            $d .= 'SSD';
        } elsif (${$drive}{$_}{'rotationrate'} eq 'unknown') {
            $d .= 'unknown type';
        } elsif (${$drive}{$_}{'rotationrate'} > 0) {
            $d .= 'spinning';
        } else {
            $d .= 'unknown type';
        }
        if (exists ${$drive}{$_}{'USB'}) {
            $d .= ' USB';
        }
        $d .= ' drive';
        if (exists ${$drive}{$_}{'descr'} and 
                    (${$drive}{$_}{'descr'} ne 'Mass Storage Device') and
                    (${$drive}{$_}{'descr'} ne 'USB Mass Storage Device')) {
            $d .= ' ' . ${$drive}{$_}{'descr'};
        }
        $eraselist{$_} = $d;
    }
    # TODO leave out unformatted drives
    getcheckform (
            \%eraselist,
            \@erasecandidates,
            "$cloner_backtitleheader: Drive erase candidates",
            'Select target drive erase candidates',
            "Please choose the drives that may be erased, in case you want to use them as target clones.\\nIf you do not want drives to be erased, just hit \"Enter\", without selecting any drive, or choose \"Cancel\" to proceed to the next question dialog." .
            "\\n\\nUse the arrow up/down keys to move between fields. Hit the space bar to select/deselect a drive. Then hit \"Enter\" when you have made your choice.",
            '18 80 6',
            \%erasedrives,
            undef,
            'off');
}

if (%erasedrives) {
    foreach (keys %erasedrives) {
        ${$drive}{$_}{'canbeerased'} = 'YES';
    }
}

# search potential target drive(s), separately for bootpool and for others,
# and if none large enough found, message user to get one and restart
my $pottarget;
my $safetyfactor = 1.2;
my $target_boot_avail = 0;
my $target_nonboot_avail = 0;
my $exists_boot_drive = 0;
my $exists_nonboot_drive = 0;
foreach (keys %$drive) {
    if (exists ${$drive}{$_}{'bootpool'}) {
        # boot drives can only take further nonboot partitions/pools
        $exists_boot_drive = 1;
        if (${$drive}{$_}{'freespace'} * $safetyfactor > $smallest_nonboot) {
            $target_nonboot_avail = 1;
        }
    } else {
        # non-boot drives can take both boot and nonboot partitions/pools
        $exists_nonboot_drive = 1;
        if (exists ${$drive}{$_}{'freespace'} and not exists ${$drive}{$_}{'canbeerased'}) {
            if (${$drive}{$_}{'freespace'} * $safetyfactor > $smallest_boot) {
                $target_boot_avail = 1;
            }
            if (${$drive}{$_}{'freespace'} * $safetyfactor > $smallest_nonboot) {
                $target_nonboot_avail = 1;
            }
        } else {
            # unpartitioned, use mediasize
            if (${$drive}{$_}{'mediasize'} * $safetyfactor > $smallest_boot) {
                $target_boot_avail = 1;
            }
            if (${$drive}{$_}{'mediasize'} * $safetyfactor > $smallest_nonboot) {
                $target_nonboot_avail = 1;
            }
        }
    }
}

my $bootpoolcanbecloned = 0;
my $nonbootpoolcanbecloned = 0;

if ($smallest_boot and $target_boot_avail) {
    $bootpoolcanbecloned = 1;
}
if ($smallest_nonboot and $target_nonboot_avail) {
    $nonbootpoolcanbecloned = 1;
}


# make dialog message
unless ($nonbootpoolcanbecloned or $bootpoolcanbecloned) {
    my $s = "Sorry!\\nThere is no available target drive for cloning.\\n\\n";
    if ($smallest_boot) {
        $s .= "The smallest boot pool is " . bytesto( $smallest_boot) . "iB large.\\n";
        $s .= "To be able to clone, you need a drive with at least " . bytesto( $safetyfactor * $smallest_boot) . "iB (" . bytestodec($safetyfactor * $smallest_boot) . "B) free space.\\n";
    }
    if ($smallest_nonboot) {
        $s .= "The smallest non-boot pool is " . bytesto( $smallest_nonboot) . "iB large.\\n";
        $s .= "To be able to clone, you need a drive with at least " . bytesto( $safetyfactor * $smallest_nonboot) . "iB (" . bytestodec($safetyfactor * $smallest_nonboot) . "B) free space.\\n";
    }
    $s .= "\\nPlease run again the \"Skunk Cloner\" after you have connected a sufficiently large drive.";
    msgbox( 
    "$cloner_backtitleheader: Drive selection stage",
    'Failure message: No potential clone target drive found',
    $s,
    '19 72');
    exit 1;
}

# if we reach here, now we can prepare the selection dialogs 
# prepare two lists of pools that can be cloned:
# first one of pools not clonable due to lack of sufficiently large target drive
# second one of clonable pools
foreach (keys %$zfspools) {
    my $zpo = $_;
    # walk through all drives
    # find these that
    # - are not part of $_ pool
    # - have no boot [pool], if the source pool is bootpool
    # - and are sufficiently large 
    foreach (keys %$drive) {
        next if (exists ${$drive}{$_}{'boottypes'} or
                    exists ${$drive}{$_}{'bootpool'} );
        # no cloning onto same drive
        next if (exists ${$drive}{$_}{'pools'} and exists ${$drive}{$_}{'pools'}{$zpo});
        next if (exists ${$zfspools}{$zpo}{$bootpool} and exists ${$drive}{$_}{'boottypes'});
        if (exists ${$drive}{$_}{'canbeerased'}) {
            next if ( ${$drive}{$_}{'mediasize'} < (${$zfspools}{$zpo}{'used'} * $safetyfactor));
        } else {
            next if ( ${$drive}{$_}{'freespace'} < (${$zfspools}{$zpo}{'used'} * $safetyfactor));
        }
        # it is said somewhere, ZFS pools shouldn't be created on MBR drives?
        # TODO find out whether this is true
        next if (not exists ${$drive}{$_}{'canbeerased'} and
                    exists ${$drive}{$_}{'partitioned'} and 
                    ${$drive}{$_}{'partitioned'} eq 'MBR');
        # no more exclusion characteristics found
        ${$zfspools}{$zpo}{'potentialclonetargets'}{$_} = 'YES';
    }
}


# now walk through the pool list again and assign the 
# pools to the following categories:
my $clonablebootable;
my $unclonablebootable;
my $clonablenonbootable;
my $unclonablenonbootable;
foreach (keys %$zfspools) {
    my $zpo = $_;
    if (exists ${$zfspools}{$_}{'bootpool'}) {
        if (exists ${$zfspools}{$_}{'potentialclonetargets'}) {
            ${$clonablebootable}{$_} = 'YES';
        } else {
            ${$unclonablebootable}{$_} = 'YES';
        }
    } else {
        if (exists ${$zfspools}{$_}{'potentialclonetargets'}) {
            ${$clonablenonbootable}{$_} = 'YES';
        } else {
            ${$unclonablenonbootable}{$_} = 'YES';
        }
    }
}

# with the above, make a dialog,
#   that first lists the pools that cannot be cloned 
#   due to lack of target free space, if any
#   and after that offers a radiolist of pools, beginning 
#   with the bootpool, to choose one to clone
my $selectedpool;
{
    my $msg = '';
    if (defined $unclonablebootable) {
        $msg .= "There is no sufficiently large target drive to clone the bootpool \"$bootpool\".\\n";
    }
    if (defined $unclonablenonbootable) {
        $msg .= "There is no sufficiently large target drive to clone the pool";
        # singular or plural?
        my $s = '';
        my $pc = 0;
        foreach (sort keys %$unclonablenonbootable) {
            if ($pc) {
                $s .= ', ';
            }
            $s .= $_;
            ++$pc;
        }
        if ($pc > 1) {
            $msg .= 's';
        }
        $msg .= ": $s\\n"; ;
    }

    my %sourcepools;
    my @sourceseq;
    if (defined $clonablebootable) {
        $sourcepools{$bootpool} = "\"$bootpool\" (Boot pool), used size " .
                ${$zfspools}{$bootpool}{'usedE'};
        push @sourceseq, $bootpool;
    }
    if (defined $clonablenonbootable) {
        foreach (sort keys %$clonablenonbootable) {
            $sourcepools{$_} = "\"$_\", used size " .
                    ${$zfspools}{$_}{'usedE'};
            push @sourceseq, $_;
        }
    }

    getradioform (
            \%sourcepools,
            \@sourceseq,
            "$cloner_backtitleheader: Source pool selection",
            'Choose source pool to be cloned',
            "Please choose the pool you want to clone." .
            "\\n\\nUse the arrow up/down keys to move between fields. Hit the space bar to select the desired pool. Then hit \"Enter\" when you have made your choice.",
            '16 80 6',
            \$selectedpool);
}


# target drive(s) selection:
# the drives must be 
# - sufficiently large
# - in case of bootpool not yet be bootable
# add info (ADDING PARTITION) or (OVERWRITING DISK) in the checkbox entries
my $sourceisboot = (exists ${$zfspools}{$selectedpool}{'bootpool'})
                    ? 1
                    : 0;
my $sourceused = ${$zfspools}{$selectedpool}{'used'};
my %targetdrvs;
my @targetseq;
foreach (sort keys %$drive) {
    next if ($sourceisboot and exists ${$drive}{$_}{'bootpool'});
    my $targetspace;
    if (exists ${$drive}{$_}{'canbeerased'}) {
        $targetspace = ${$drive}{$_}{'mediasize'};
    } elsif (exists ${$drive}{$_}{'partitioned'} and 
                ${$drive}{$_}{'partitioned'} ne 'MBR') {
        $targetspace = ${$drive}{$_}{'freespace'};
    } else {
        $targetspace = ${$drive}{$_}{'mediasize'};
    }
    if (defined $targetspace and $targetspace * $safetyfactor > $sourceused) {
        my $d = '';
        $d .= ${$drive}{$_}{'mediasizeE'} . 'B ';
        if (exists ${$drive}{$_}{'partitioned'}) {
            $d .= 'partitioned (' . ${$drive}{$_}{'partitioned'} . ') ';
        } else {
            $d .= 'unpartitioned ';
        }
        if (exists ${$drive}{$_}{'canbeerased'}) {
            $d .= '[will be erased] ';
        }
        if (${$drive}{$_}{'rotationrate'} eq '0') {
            $d .= 'SSD';
        } elsif (${$drive}{$_}{'rotationrate'} eq 'unknown') {
            $d .= 'unknown type';
        } elsif (${$drive}{$_}{'rotationrate'} > 0) {
            $d .= 'spinning';
        } else {
            $d .= 'unknown type';
        }
        if (exists ${$drive}{$_}{'USB'}) {
            $d .= ' USB';
        }
        $d .= ' drive';
        if (exists ${$drive}{$_}{'descr'} and ${$drive}{$_}{'descr'} ne 'Mass Storage Device') {
            $d .= ' ' . ${$drive}{$_}{'descr'};
        }
        $targetdrvs{$_} = $d;
        push @targetseq, $_;
    }
}

my %targetsselected;
{
    do {
        getcheckform (
                \%targetdrvs,
                \@targetseq,
                "$cloner_backtitleheader: Target drive selection",
                'Choose target drive(s)',
                "Please choose the drive(s) you want to clone onto.\\n" .
                "If you select a single drive, a stripe pool will be created, without redundancy.\\n" .
                "If you select multiple drives, a mirrored pool will be created.\\n" .
                "\\nUse the arrow up/down keys to move between fields. Hit the space bar to select/deselect a drive. Then hit \"Enter\" when you have made your choice.",
                '18 80 6',
                \%targetsselected,
                undef,
                'off');
    } while (not %targetsselected or not keys %targetsselected);
}

    # now ask user whether (s)he wants only a quasi-identical clone
    # (e.g. for replacing a boot drive in case of failure)
    # or to clone a boot disk for another, separate computer which 
    # shall contain exactly the same fine-tuned-configuration,
    # but needs some certain postconfiguration, like:
    #   - hostname
    #   - IP (or alternatively DHCP)
    #   - ...?
    
my $selectedclonetype;
{
    my %clonetypes = (
        '1:1' => "Clone as replacement backup for same machine",
        'new' => "Clone for use with another computer",
    );
    my @clonetypeseq = ('new', '1:1',);
    getradioform (
            \%clonetypes,
            \@clonetypeseq,
            "$cloner_backtitleheader: Determine clone type",
            'Choose cloning type',
            "Please choose the type of cloning you want.\\n" .
            "\\nUse the arrow up/down keys to move between fields. Hit the space bar to select the desired action. Then hit \"Enter\" when you have made your choice.\\n\\n" .
#             "You have two possibilities.\\n\\n" .
            "- You can clone a boot disk for another, separate computer which shall contain exactly the same fine-tuned-configuration, except for some particular properties, like a different hostname, and using fixed IP/netmask or alternatively DHCP instead. If you choose this case, you will be presented with some additional dialogs to configure these things.\\n" .
            "- Alternatively you can create an identical clone, e.g. for creating a drop-in spare boot backup drive in case of boot drive failure (which would create conflicts on the network if concurrently being used together with the original).\\n",
            '22 80 2',
            \$selectedclonetype);
}


# if this is cloning for separate computer:
#   - ask for hostname +IP/NM or DHCP:
#     (insert defaults from currently running computers into mask and tell user to modify these)
#
# derive zpool name:
#   when clone for other computer: hostname_zroot
#   when backup clone for same computer: hostname_zroot_clone_datetag
my $newpoolname;
my $dt = getdirdatetag();

my $newhostname;
my $newif;
my $newIP;
my $newnetmask;
my $newgateway;

my $invalid;

my $myif;
my $myip;
my $mynmbits;
my $myifonl;
my $mydhcp;
my $mydefr;


if ($selectedclonetype eq 'new') {
    do {
        # 
        my $formtext = '';
        if (defined $invalid) {
            $formtext .= $invalid . "\\n";
            $invalid = undef;
        }

        my %fieldlist = (
            'Hostname'  => 'Hostname',
            'Poolname'  => 'Poolname',
            'Interface' => 'Interface',
            'IP'        => 'IP',
            'Netmask'   => 'Netmask',
            'Gateway'   => 'Gateway',
        );
        my @fieldseq = ( 'Hostname', 'Poolname', 'Interface', 'IP', 'Netmask', 'Gateway');
        my $backtitle = "$cloner_backtitleheader: Basic network setup";
        my $title = "Enter clone network setup data";
        $formtext .= "This is the internet configuration of the original computer.\\nIf you use static IPs, you need to assign another, non-conflicting IP, maybe also netmask and gateway.\\nIf you use DHCP on the clone instead, just enter \"dhcp\" as IP, then DHCP will be used and the other fields are ignored.\\n" .
        "Please note that if the target computer uses a different network interface, you will need to manually change /etc/rc.conf to this interface.";
        my $dimensions = '20 70 5';
        my %fields;
        my %labelpos = (
            'Hostname'  => '1 1',
            'Poolname'  => '2 1',
            'Interface' => '3 1',
            'IP'        => '4 1',
            'Netmask'   => '5 1',
            'Gateway'   => '6 1',
        );
        my %fieldposdim = (
            'Hostname'  => '1 10 30 30',
            'Poolname'  => '2 10 30 30',
            'Interface' => '3 10 30 30',
            'IP'        => '4 10 30 30',
            'Netmask'   => '5 10 30 30',
            'Gateway'   => '6 10 30 30',
        );
        
        ($myif, $myip, $mynmbits, $myifonl, $mydhcp, $mydefr) = getmyip();
        if (defined $myip) {
            # print "Interf = '$myif'\nIP = '" . getdotipstr( $myip) . "'\nnetmaskbits = /'$mynmbits'\nnetmaskdots = '" . getdotnetmaskstr($mynmbits) . "'\nifonline = '$myifonl'\nDHCP = '$mydhcp'\ndefaultrouter = '" . getdotipstr( $mydefr) . "'\n";
        } else {
            die "Error: '$myif'\n";
        }

        my $hname = `hostname`;
        chomp $hname;
        my $hn = $hname . '_clon';
        $fields{'Hostname'}     = $hn;
        $fields{'Poolname'}     = $hn . 'root';
        $fields{'Interface'}    = $myif;
        if ($mydhcp) {
            $fields{'IP'}       = 'DHCP';
            $fields{'Netmask'}  = '';
            $fields{'Gateway'}  = '';
        } else {
            $fields{'IP'}       = getdotipstr( $myip);
            $fields{'Netmask'}  = getdotnetmaskstr($mynmbits);
            $fields{'Gateway'}  = getdotipstr( $mydefr);
        }
        
        getdataform(
            \%fieldlist,
            \@fieldseq,
            $backtitle,
            $title,
            $formtext,
            $dimensions,
            \%fields,
            \%labelpos,
            \%fieldposdim
        );

        $newhostname = $fields{'Hostname'};
        $newpoolname = $fields{'Poolname'};
        $newif = $fields{'Interface'};
        $newIP = $fields{'IP'};
        $newnetmask = $fields{'Netmask'};
        $newgateway = $fields{'Gateway'};
        
        # (rudimentary) validity check
        if ( not length( $newhostname) or
                    $newhostname eq $hname or
                    $newhostname =~ /^\s+$/) {
            $invalid .= "Invalid Hostname. Please enter a hostname that is different from the original.\\n";
        }
        if (not length ($newpoolname) or
                    $newhostname =~ /^\s+$/ or
                    $newpoolname eq $bootpool
            ) {
            $invalid .= "Invalid Poolname. Please enter a poolname that is different from the original.\\n";
        }
        if (not length ($newIP) or
                    $newIP =~ /^\s+$/ or
                    (not $newIP =~ /dhcp/i and not $newIP =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) or
                    (iptonum($newIP) == $myip)
        ) {
            $invalid .= "Invalid IP. Please enter a valid IP different from the original one, alternatively DCHP or DHCP variant\\n";
        }
        # in case of DHCP ignore netmask and gateway
        unless ($newIP =~ /dhcp/i) {
            if (not length ($newnetmask) or
                        $newnetmask =~ /^\s+$/ or
                        not ($newnetmask =~ /^0x[01-9a-fA-F]$/ or 
                                $newnetmask =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/)
            ) {
                $invalid .= "Invalid netmask. Please enter a valid netmask, either in hex (prepended with 0x) or one in dot notation.\\n";
            }
            if (not length ($newgateway) or
                        $newgateway =~ /^\s+$/ or
                        not $newgateway =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/
            ) {
                $invalid .= "Invalid gateway. Please enter a valid IP4 address in dot notation.\\n";
            }
        }
    } while (defined $invalid);

} else {                # -> if ($selectedclonetype eq '1:1') {
    $newpoolname = $hostname . 'clone' . $dt;
} 


$newIP = iptonum( $newIP);
$newnetmask = netmasktobits( $newnetmask);
$newgateway = iptonum( $newgateway);
    
    
    # check for sc being active in /boot/loader.conf
    # and offer to deactivate/comment it out in clone
    
my $f_boot_loader_conf = '/boot/loader.conf';
my $changetovt = 0;
if (exists ${$zfspools}{$selectedpool}{'bootpool'}) {
    my $bolocor = read_a_file( $f_boot_loader_conf);
    die unless (defined $bolocor);
    if ($$bolocor =~ /^kern\.vty="([scvt]+)"$/im) {
        my $con = $1;
        if (lc $con eq 'sc') {
            # offer the user to comment out the sc line to
            # make sure (s)he can boot even with UEFI garbage
            if (yesno(
            "$cloner_backtitleheader: Configuration stage",
            'Console configuration step',
            "Your system is running the sc console.\\nHowever, if you need to run the clone on an UEFI system, the vt newcons must be activated.\\n\\n\\nIf you press \"Enter\", the vt newcons console will be activated on the clone. It is recommended to run the Skunk Installer graphics configuration on the cloned system (using command \"/root/bootie -c\") to autoconfigure the optimum graphics and console, after installing the cloned system media there.\\nIf you choose \"Cancel\", the console configuration will not be changed.",
            '19 72')) {
                # change sc to vt...
                $changetovt = 1;
            }
        }
    }
}


# make a warning about long running time
unless (yesno(
    "$cloner_backtitleheader: Confirmation stage",
    'Confirmation',
    "The Skunk Cloner is now ready to run.\\n" .
    "Please be patient, as this might take a long time, depending on your systems speed.\\n\\n" . 
    "If you suspect your system hanging, which under some circumstances can happen if drives turn out bad while transferring the data, please use \"ps\" or \"top\" to find out whether the zfs send/receive processes are still active. In case of hardware (drive) problems/failure, you will find according messages in /var/log/messages.\\n\\n" . 
    "Do you want to start the cloning process now? Then please choose \"Yes\".\\nIf you choose \"No\" instead, the Skunk Cloner will abort without any action.",
    '19 72'))
{
    exit 1;
}
    
# now produce the command batch necessary to clone the pool.
my $cmd = '';

{
    # remove old cloner snapshot if any were there
    my $snp = getzfslistsnap();
    my (@snaps) = $snp =~ /^($selectedpool.*?$clonesnap)\s.*?$/mg;
    foreach (sort @snaps) {
        $cmd .= "zfs destroy -R $_\n";
    }
    unless ($cmd eq '') {
        executer( $cmd);
        $cmd = '';
    }
}

my $snp;
my $dnum = 0;
{
    foreach (sort keys %targetsselected) {
#         # TODO add physical overwrite/zeroing option dialog
#         if (exists (${$drive}{$_}{'canbeblanked'})) {
#             # user ordered to zero out the drive
#             # TODO make some dd erase loop with progress bar dialog
# #             $cmd .= "dd if=/dev/zero of=/dev/$_" . "p$zfspartno bs=16k count=64\n";
# 
#         
# #         } elsif (exists ${$drive}{$_}{'canbeerased'} and exists ${$drive}{$_}{'partitioned'} ) {
        if (exists ${$drive}{$_}{'canbeerased'} and exists ${$drive}{$_}{'partitioned'} ) {
            # normally dd zeroing shouldn't be necessary, but being on safe side is better
#             $cmd .= "dd if=/dev/zero of=/dev/$_ bs=16k count=64\n";
#             executer( $cmd);
#             $cmd = '';
            # user ordered to erase the drive
            # gpart errors sometimes if we use dd to clean blocks
            $cmd .= "gpart destroy -F $_\n";
            executer( $cmd);
            $cmd = '';
            delete ${$drive}{$_}{'partitioned'};
            delete ${$drive}{$_}{'partition'};
        }
        
        # does the drive have a partition table?
        # if not, make a GPT
        unless (exists ${$drive}{$_}{'partitioned'}) {
            my $gpa = getgpartshow();
            my ($part) = $gpa =~ /^=>\s+\d+\s+\d+\s+$_\s+(\w+)/ms;
            unless (defined $part) {
                # we need more than 2 partitions, so specify a Linux- and
                # Windows-compatible size of 128 entries
                # https://bugs.freebsd.org/bugzilla/show_bug.cgi?id=229977
                $cmd .= "gpart create -s gpt -n 128 $_\n";
            }
        }
    }

    # in case of bootable create the freebsd-boot+efi partitions
    foreach (sort keys %targetsselected) {
        if (exists ${$zfspools}{$selectedpool}{'bootpool'}) {
            $cmd .= "gpart add -a 4k -s 512K -t freebsd-boot $_\n";
            # now get partition number of freebsd-boot partition
            executer( $cmd);
            $cmd = '';
            my $gpa = getgpartshow( $_);
            my ($bootpartno) = $gpa =~ /^\s+\d+\s+\d+\s+(\d+)\s+freebsd-boot\s+/ms;
            
            die if (not defined $bootpartno);
            # write bootstrap block 
            # create freebsd-boot partition for non-UEFI (CSM) booting
            # https://forums.freebsd.org/threads/how-to-create-a-bootdisk-that-can-boot-a-crypted-zroot-pool.81812/#post-528342
            $cmd .= "gpart bootcode -b /boot/pmbr -p /boot/gptzfsboot -i $bootpartno $_\n";
            
            # create efi boot partition for UEFI booting
            $cmd .= "gpart add -a 4k -s 1M -t efi $_\n";
            # now get partition number of freebsd-boot partition
            executer( $cmd);
            $cmd = '';
            $gpa = getgpartshow( $_);
            my ($efipartno) = $gpa =~ /^\s+\d+\s+\d+\s+(\d+)\s+efi\s+/ms;
            # for the following I have exploited the bsdforen.de post of pit234a
            # https://www.bsdforen.de/threads/zfs-auf-neue-platte-clonen.36443/post-328248
            # big thanks go to pit234a
            die if (not defined $efipartno);
            # TODO add 'partitioned', 'partition' for CSM+EFI
            
            my $mntdir = '/root';
            $cmd .= "cd /root\n";
            $cmd .= "newfs_msdos -F 12 -L EFISYS /dev/$_" . "p$efipartno\n";
            $cmd .= "mkdir $mntdir/efi0\n";
            $cmd .= "mount -t msdosfs -o rw /dev/$_" . "p$efipartno $mntdir/efi0\n";
            $cmd .= "mkdir -p $mntdir/efi0/efi/boot\n";
            $cmd .= "cp /boot/loader.efi $mntdir/efi0/efi/boot/BOOTx64.efi\n";
            $cmd .= "umount $mntdir/efi0\n";
            $cmd .= "rm -r $mntdir/efi0\n";
        }
    }
        
    # now create the necessary freebsd-zfs partitions
    my $zfstarget = '';
    foreach (sort keys %targetsselected) {
        $cmd .= "gpart add -t freebsd-zfs -l $newpoolname $_\n";
        executer( $cmd);
        $cmd = '';
        my $gpa = getgpartshow( $_);
        my ($zfspartno) = $gpa =~ /^\s+\d+\s+\d+\s+(\d+)\s+freebsd-zfs\s+/ms;
        
        die if (not defined $zfspartno);
        # TODO add 'partitioned', 'partition' for freebsd-zfs
        
        # if there was another zfs partition zfs may refuse to create 
        # a new one in its place.
        # So make sure its header is gone by using dd
        $cmd .= "dd if=/dev/zero of=/dev/$_" . "p$zfspartno bs=16k count=64\n";
        unless ($dnum) {
            $zfstarget = "/dev/$_" . "p$zfspartno";
            $dnum = 1;
        } else {
            $zfstarget .= " /dev/$_" . "p$zfspartno";
            ++$dnum;
        }
    }
    my $mirror = ($dnum > 1)
            ? ' mirror'
            : '';
    $cmd .= "zpool create -f -R /tmp/$newpoolname $newpoolname$mirror $zfstarget\n";
    $cmd .= "zfs snap -r $selectedpool\@$clonesnap\n";
    $cmd .= "zfs send -R $selectedpool\@$clonesnap | zfs recv -Fduv $newpoolname\n";
    if ($selectedpool eq $bootpool) {
        $cmd .= "zpool set bootfs=$newpoolname/ROOT/default $newpoolname\n";
    }
    if ($selectedclonetype eq 'new') {
        $cmd .= "zfs mount $newpoolname/ROOT/default\n";
        # now do changes:
        # in /etc/rc.conf:
        $cmd .= "$sysmod /tmp/$newpoolname$f_rc_conf hostname=$newhostname double\n";
        if ($newif ne $myif) {
            $cmd .= "$sysmod /tmp/$newpoolname$f_rc_conf 'ifconfig_$myif=' delete\n";
        }
        if ($newIP =~ /DHCP/i) {
            $cmd .= "$sysmod /tmp/$newpoolname$f_rc_conf 'ifconfig_$newif=$newIP' double\n";
            # if source bootpool had static IP, defaultrouter is still there.
            # Remove it.
            $cmd .= "$sysmod /tmp/$newpoolname$f_rc_conf defaultrouter= delete\n";
        } else {
            $cmd .= "$sysmod /tmp/$newpoolname$f_rc_conf 'ifconfig_$newif=inet " .
                        getdotipstr( $newIP) .
                        " netmask " . getdotnetmaskstr( $newnetmask) .
                        "' double\n";
            $cmd .= "$sysmod /tmp/$newpoolname$f_rc_conf defaultrouter=" . 
                        getdotipstr( $newgateway) . " double\n";
        }
    }
    executer( $cmd);
    $cmd = '';
    
    if ($changetovt) {
        my $bolocor = read_a_file( $f_boot_loader_conf);
        $$bolocor =~ s/^(kern\.vty=")[scvt]+(")$/$1vt$2/im;
        write_a_file( "/tmp/$newpoolname$f_boot_loader_conf", $bolocor);
    }
    
    # finally clean up the temporary receive snapshots
    $snp = getzfslistsnap();
    my (@snaps) = $snp =~ /^($newpoolname.*?$clonesnap)\s.*?$/mg;
    foreach (sort @snaps) {
        $cmd .= "zfs destroy -R $_\n";
    }
#     unless ($cmd eq '') {
#         executer( $cmd);
#         $cmd = '';
#     }
    # remove cachefiles to avoid unwanted mounting of $bootpool
    $cmd .= "[0 1]rm /tmp/$newpoolname/boot/zfs/zpool.cache\n";
    $cmd .= "[0 1]rm /tmp/$newpoolname/etc/zfs/zpool.cache\n";
    $cmd .= "zfs unmount $newpoolname/ROOT/default\n";
    $cmd .= "zpool export $newpoolname\n";
    executer( $cmd);
    $cmd = '';
}

{
    # clean up cloner snapshot
#     my $snp = getzfslistsnap();
    my (@snaps) = $snp =~ /^($selectedpool.*?$clonesnap)\s.*?$/mg;
    foreach (sort @snaps) {
        $cmd .= "zfs destroy -R $_\n";
    }
    unless ($cmd eq '') {
        executer( $cmd);
        $cmd = '';
    }
}

print "\nCloning finished successfully!\n";
my $plural = ($dnum > 1)
        ? 's'
        : '';
my $antiplural = ($dnum > 1)
        ? ''
        : 's';
if ($selectedclonetype eq 'new') {
    print "The target drive$plural now contain$antiplural a clone of the source pool.\n";
    print "You can now remove and use the target drive$plural.\n";
} else {
    print "The target drive$plural now contain$antiplural an exact copy of the source pool.\n";
    print "You can now remove and stash away the target drive$plural\n";
}

exit 0;