#!/usr/bin/perl
# cPanel12 - pkgacct-pXa                           Copyright(c) 2009 cPanel, Inc.
#                                                           All rights Reserved.
# copyright@cpanel.net                                         http://cpanel.net
# This code is subject to the cpanel license. Unauthorized copying is prohibited
# $Desc: v3.0.0-274-g545221d$

package Script::Pkgacct::pXa;

use IPC::Open3  ();
use POSIX       ();
use Time::Local ();

use File::Path ();
use File::Copy ();

use Fcntl ();
use Cwd   ();

# rlb3: Why use IO::Handle?
use IO::Handle;

use strict;
## Package scope to allow for redefinition in test cases
our $_etc = '/etc';

__PACKAGE__->script(@ARGV) unless caller();

sub script {
    my ( $class, @argv ) = @_;

    $| = 1;

    my $psaversion = getpsaversion();

    unless ( defined $psaversion ) {
        die("Transfers of accounts from this system's version of Plesk(tm) are not supported.");
    }

    ### process args: $user and $nosplit
    my $user    = $argv[0];
    my $nosplit = 0;
    if ( $argv[1] eq '--nosplit' ) {
        $nosplit = 1;
    }

    ### init vars: $cpuser, $system, $cpflags
    my $cpuser  = clean_username( $user, 0 );
    my $system  = ( POSIX::uname() )[0];
    my $cpflags = "-a";
    if ( $system =~ /freebsd/i ) {
        $cpflags = "-pR";
    }

    ### ensure not root
    if ( $user eq "root" ) {
        print "You cannot copy the root user.\n";
        exit;
    }

    my $tarroot    = find_tarroot( $argv[1] );
    my $prefix     = 'cpmove-';
    my $skipacctdb = pop(@argv) eq '--skipacctdb';

    ### init vars: user info, $homedir ($dns, $lcdns)
    my @getpwnam = _getpwnam($user);
    if ( !@getpwnam ) {
        print "Invalid Account\n";
        exit;
    }

    my $homedir = $getpwnam[7];
    if ( -l $homedir ) {
        $homedir = readlink($homedir);
    }
    $homedir =~ /([^\/]+)\/?$/;
    my $dns   = $1;
    my $lcdns = lc($1);

    ### ensure dns
    if ( $dns eq "" ) {
        print "Unable to find domain name for $user\n";
        exit;
    }

    print "pXa DNS is $lcdns\n";

    ### clean working directory
    my $work_dir = "${tarroot}/${prefix}${cpuser}";
    if ( -d $work_dir && !-l $work_dir ) {
        system( "rm", "-rf", $work_dir );
    }
    if ( -f "$work_dir.tar.gz" && !-l "$work_dir.tar.gz" ) {
        system( "rm", "-rf", "$work_dir.tar.gz" );
    }

    # As far as I can tell this file is created to prevent the race condition
    # of someone stealing the permissions of the tarfile before the file is written
    if ($nosplit) {
        open( my $cpm, ">$work_dir.tar.gz" );
        close($cpm);
        chmod( 0640, "$work_dir.tar.gz" );
    }

    ### create working directory
    if ( !-e $work_dir ) {
        my @DIRS = qw(
          cp logs mysql psqlmm mma mma/pub mma/priv
          va vad fp vf homedir homedir/etc homedir/mail
          meta cron dnszones sslcerts sslkeys
          homedir/tmp homedir/tmp/awstats
        );

        mkdir( $work_dir, 0700 );
        foreach my $dir (@DIRS) {
            mkdir( "$work_dir/$dir", 0700 );
        }
    }
    else {
        print "$work_dir exists, please remove it and try again\n";
        exit;
    }

    ### Output homedir_paths
    my $homedir_paths = "$work_dir/meta/homedir_paths";
    sysopen( my $home_fh, $homedir_paths, &Fcntl::O_WRONLY | &Fcntl::O_CREAT | &Fcntl::O_EXCL, 0600 );
    print {$home_fh} "$homedir\n";
    my $abshomedir = Cwd::abs_path($homedir);
    if ( $abshomedir ne $homedir ) {
        print {$home_fh} "$abshomedir\n";
    }
    close($home_fh);

    ### Grab crontab
    print "pXa Grabbing crontab for....";
    my $crontab = grab_crontab($user);
    if ( open( my $fh, '>', "$work_dir/cron/$cpuser" ) ) {
        print {$fh} $crontab;
        close($fh);
    }
    print 'Done' . "\n";

    my $psa1 = _compute_psa1();
    set_psa1($psa1);

    my $adminpass = _get_adminpass($psa1);
    _create_my_cnf($adminpass);
    _copy_passwd_to_shadow( $work_dir, $getpwnam[1] );

    ### init var: $psaversion, $sysuserid, $domainid
    my $sysuserid = 0;
    if ( $psaversion >= 5 ) {
        $sysuserid = getpsasysuid( $user, $psaversion );
    }

    my $domainid = domainid( $psaversion, $dns, $sysuserid, $user );
    my $clientid = clientid($domainid);

    ## case 27550: copy mailman lists/archives for plesk transfers
    my $cpargs = '-a';
    if ( $system =~ /freebsd/i ) {
        $cpargs = '-Rpf';
    }
    print "Copying mailman lists and archives....";
    my $srcbase  = '/var/lib/mailman';
    my $destbase = '/usr/local/cpanel/3rdparty/mailman';
    ## NOTE: currently support lists on main $dns
    #my $sql = "select ml.name, d.name from MailLists ml, domains d, clients cl where ml.dom_id = d.id and d.cl_id = cl.id and cl.pname = '$user'";
    my $sql               = "select ml.name, d.name from MailLists ml, domains d where ml.dom_id = d.id and d.name = '$dns'";
    my @list_domain_pairs = split( /\n/, psasqlcmd($sql) );
    my $has_mailman_lists = scalar @list_domain_pairs;
    if ($has_mailman_lists) {
        open( my $mmreset, '>', "$work_dir/meta/mailman_reset_hostname" );
        for my $pair (@list_domain_pairs) {
            my ( $maillist, $domain ) = split( /\t/, $pair );
            my $oldname       = lc($maillist);
            my $list_fullpath = "$srcbase/lists/$oldname";
            next unless ( -e $list_fullpath && -d _ );
            my $newname = sprintf( "%s_%s", $oldname, $domain );
            system( 'cp', $cpargs, $list_fullpath,                            "$work_dir/mm/$newname" );
            system( 'cp', $cpargs, "$srcbase/archives/private/$oldname",      "$work_dir/mma/priv/$newname" );
            system( 'cp', $cpargs, "$srcbase/archives/private/$oldname.mbox", "$work_dir/mma/priv/$newname.mbox" );
            rename( "$work_dir/mma/priv/$newname.mbox/$oldname.mbox", "$work_dir/mma/priv/$newname.mbox/$newname.mbox" );
            ## create symlink for public lists only
            if ( -e "$srcbase/archives/public/$oldname" ) {
                system( 'ln', '-s', "$destbase/archives/private/$newname", "$work_dir/mma/pub/$newname" );
            }
            print $mmreset "$newname: $domain\n";
        }
        close($mmreset);
    }
    print "Done\n";

    ### copying DNS zone
    print "pXa Grabbing DNS Zone...";
    my $zone_data = get_zone($domainid);
    if ($zone_data) {
        if ( open( my $fh, '>', "$work_dir/dnszones/$lcdns" ) ) {
            print {$fh} $zone_data;
            close($fh);
        }
    }
    print 'Done' . "\n";

    ### copying SSL certs
    print "pXa Grabbing SSL Cert...";
    my $ssl_data = get_ssl($dns);
    if ($ssl_data) {
        foreach my $ssl (@$ssl_data) {
            if ( open( my $fh, '>', "$work_dir/sslcerts/$lcdns.crt" ) ) {
                print {$fh} $ssl->{cert};
                close $fh;
            }
            if ( open( my $fh, '>', "$work_dir/sslkeys/$lcdns.key" ) ) {
                print {$fh} $ssl->{'pvt_key'};
            }
        }
    }
    print 'Done' . "\n";

    ### copying frontpage file
    if ( -e "/usr/local/frontpage/www.${dns}:80.cnf" ) {
        print "Copying frontpage file....";
        system( "cp", "/usr/local/frontpage/www.${dns}:80.cnf", "$work_dir/fp" );
        print "Done\n";
    }

    ### init var $maildir
    my $maildir;
    if ( -e "/var/qmail/mailnames" ) {
        opendir( MN, "/var/qmail/mailnames" );
        ## pek FIXME: won't this pick up '.' and '..'?? Confirmed.
        my @FILES = readdir(MN);
        closedir(MN);
        if ( scalar @FILES ) {
            $maildir = "/var/qmail";
        }
    }
    ## pek FIXME: should this be an elsif?
    if ( -e "/usr/local/psa/qmail/mailnames" ) {
        opendir( MN, "/usr/local/psa/qmail/mailnames" );
        my @FILES = readdir(MN);
        closedir(MN);
        if ( $#FILES > -1 ) {
            $maildir = "/usr/local/psa/qmail";
        }
    }
    ## pek FIXME: should this be an elsif?
    if ( -e "/usr/local/plesk/qmail/mailnames" ) {
        opendir( MN, "/usr/local/plesk/qmail/mailnames" );
        my @FILES = readdir(MN);
        closedir(MN);
        if ( $#FILES > -1 ) {
            $maildir = "/usr/local/plesk/qmail";
        }
    }
    ### ensure var $maildir
    if ( $maildir eq "" ) {
        print "Cannot find the qmail directory\n";
        exit;
    }

    print "pXa Copying Mail files....";
    my @POPS;
    my @domains = ($dns);
    foreach my $domain (@domains) {
        my $lc_domain = lc $domain;

        ### create working dir
        system( 'mkdir', '-p', "$work_dir/homedir/etc/$lc_domain" );
        system( 'mkdir', '-p', "$work_dir/homedir/mail/$lc_domain" );

        my @NAMES = @{ _collect_mailnames( $maildir, $domain ) };
        my @VAs;

        ### loop on mailname: collect @VAs and @POPS
        foreach my $mailname (@NAMES) {
            _push_mail_aliases_to_VAs( $domain, $mailname, \@VAs );
            _push_default_mailnames_to_VAs_POPS( $maildir, $domain, $mailname, \@VAs, \@POPS );
            _push_distinct_mailnames_to_pops( $maildir, $domain, $mailname, \@POPS );
        }

        my $default = _define_default_from_qmail( $maildir, $domain );
        _process_default_to_VAs( $default, $user, \@VAs );
        _output_VA_file( $work_dir, $lc_domain, \@VAs );
    }
    print "Done\n";

    collect_autoresponders( $dns, $work_dir );

    ### collect @WEBUSERS
    opendir( USERS, "$homedir/web_users" );
    my @WEBUSERS = readdir(USERS);
    @WEBUSERS = grep( !/^\./, @WEBUSERS );
    closedir(USERS);

    print "pXa Copying proftpd file....";
    open( PROFTPDPASS, ">$work_dir/proftpdpasswd" );
    ### print each $webuser/shadow pass in PROFTPDPASS file
    foreach my $webuser (@WEBUSERS) {
        my $spass;
        ## pek FIXME: why is this opened each time?
        open( S, "/etc/shadow" );
        while (<S>) {
            my $muser;
            my $passwd;
            ( $muser, $passwd, undef ) = split( /:/, $_, 3 );
            if ( $webuser eq $muser ) {
                $spass = $passwd;
                last;
            }
        }
        close(S);

        $webuser = clean_username( $webuser, 0 );
        print PROFTPDPASS "${webuser}:${spass}:-1:-1::/dev/null:/bin/ftpsh\n";
    }
    close(PROFTPDPASS);
    print "Done\n";

    ### copy www logs
    print "pXa Copying www logs....";
    system("cp $homedir/logs/access_log $work_dir/logs/${lcdns} 2>/dev/null");
    system("cp $homedir/statistics/logs/* $work_dir/logs/${lcdns} 2>/dev/null");
    print "Done\n";

    ### copy awstats data
    my $awstats_dir      = "$homedir/statistics/webstat";
    my $awstats_conf     = "/usr/local/psa/etc/awstats/awstats.$dns-http.conf";
    my $awstats_dest_dir = "$work_dir/homedir/tmp/awstats";

    if ( -d $awstats_dir && -f $awstats_conf ) {
        print "Copying AWstats data...";

        unless ( -d $awstats_dest_dir ) {
            File::Path::mkpath($awstats_dest_dir) or die("Unable to create AWstats directory in cpmove archive: $!");
        }

        opendir( my $dh, $awstats_dir ) or die("Unable to open AWstats directory $awstats_dir for reading: $!");

        while ( my $old = readdir($dh) ) {
            next unless $old =~ /^awstats([0-9]+)\.$dns-http\.txt$/;

            my $new = "awstats$1.$lcdns.txt";

            unless ( File::Copy::copy( "$awstats_dir/$old", "$awstats_dest_dir/$new" ) ) {
                die("Unable to copy $awstats_dir/$old into cpmove archive: $!");
            }
        }

        closedir($dh);

        #
        # Now, read in the existing AWstats configuration file for this site, and
        # apply changes to make it suitable for use in a cPanel environment, while
        # writing the result to the location as follows.
        #
        my $new_awstats_conf = "$work_dir/homedir/tmp/awstats/awstats.$lcdns.conf";

        create_patched_awstats_conf(
            $awstats_conf,
            $new_awstats_conf,
            {
                'cpuser'  => $cpuser,
                'domain'  => $lcdns,
                'logfile' => "/usr/local/apache/domlogs/$lcdns",
                'aliases' => [$lcdns]
            }
        );

        print "Done\n";
    }

    ### (grab mysql dbs)
    unless ($skipacctdb) {
        print "pXa Grabbing mysql dbs...";

        ### determine @DBS
        my @DBS;
        if ($psa1) {
            push( @DBS, "$user" );
        }
        else {
            @DBS = dbs( $domainid, 'mysql' );
        }
        print "The database list contains: " . join( ',', @DBS ) . "\n";

        my @options = ( '-c', '-Q', '-q' );
        ### mysqldumpdb on @DBS
        foreach my $db (@DBS) {
            my $sql_file = "$work_dir/mysql/${db}.sql";
            mysqldumpdb( { 'options' => [@options], 'db' => $db, 'file' => $sql_file } );
        }

        my @db_users = db_users( $domainid, 'mysql' );
        my @mysql_grants = (
            collect_mysql_default_grants( $cpuser, $domainid ),
            collect_mysql_grants_for_user( \@db_users )
        );

        ### output mysql grants
        if ( open( my $grants_h, '>', "$work_dir/mysql.sql" ) ) {
            foreach my $grant_line (@mysql_grants) {
                print {$grants_h} $grant_line . "\n";
            }

            print {$grants_h} "FLUSH PRIVILEGES;\n";
            close $grants_h;
        }
        print "Done\n";
    }

    ### copy horde tables
    if ( db_exists('horde') ) {
        print "Copying horde databases...\n";
        _dump_horde_mysqldb( $work_dir, $dns, $user );
        print "Done\n";
    }

    ### copy parked domains
    if ($domainid) {
        print 'Copying parked domains...';
        if ( open( my $pds_h, '>', "$work_dir/pds" ) ) {
            my @parked = split( /\n/, psasqlcmd("SELECT name FROM domainaliases WHERE dom_id = $domainid") );
            foreach my $parked (@parked) {
                print {$pds_h} $parked . "\n";

                ## FIXME?: the "my $vds_h" should probably be within the 'if', and the close
                ##   should probably be within the if block...
                my $vds_h;
                if ( open( $vds_h, '>', "$work_dir/vad/$parked" ) ) {
                    print {$vds_h} "$parked: $lcdns\n";
                }
                close($vds_h);
            }
            close($pds_h);
        }
        print "Done\n";
    }

    ### grab postgres dbs (gets complicated)
    ## pek TODO: skipping, do not have sample data for this chunk
    print 'pXa Grabbing postgres dbs...';
    my @pgdb = dbs( $domainid, 'postgresql' );
    my ( $pg_user, $pg_pass ) = pg_pass();
    my ( $parent_rdr, $child_wtr );
    foreach my $db (@pgdb) {
        pipe( my $parent_rdr, my $child_wtr );
        fork_code(
            {
                user => $pg_user,
                wait => 0,
                args => [$child_wtr],
                code => sub {
                    my @pg = _getpwnam($pg_user);
                    my ($child_wtr) = @_;
                    close $parent_rdr;
                    my $pg_dump = find_pg_dump();
                    local $ENV{'PGUSER'} = $pg[0];
                    local $ENV{'HOME'}   = $pg[7];
                    open( my $fh, '-|', $pg_dump, '-b', '--format=t', $db );
                    my $buffer;

                    while (<$fh>) {
                        $buffer .= $_;
                    }
                    print {$child_wtr} $buffer;
                    close $child_wtr;
                    close $fh;
                },
            }
        );
        close $child_wtr;
        open( my $fd_h, '>', "$work_dir/psql/${user}_${db}.tar" );
        while (<$parent_rdr>) {
            print {$fd_h} $_;
        }
        close $parent_rdr;
        close $fd_h;
    }
    print "Done\n";

    ### grab postgresql privs
    print "pXa Grabbing PostgreSQL privileges...";

    if ( open( my $pg_grants, '>>', "$work_dir/psql_grants.sql" ) ) {
        foreach my $db (@pgdb) {
            my $tmp = $db;
            $tmp =~ s/_//g;
            print {$pg_grants} "GRANT ALL ON DATABASE ${user}_${tmp} TO $user\;\n";
        }
        close $pg_grants;
    }

    my @pg_users = db_users( $domainid, 'postgresql' );
    if ( open( my $pg_grants, '>>', "$work_dir/psql_grants.sql" ) ) {
        foreach my $db (@pgdb) {
            my $pg_users = find_pgdb_user($db);
            foreach my $pg_user ( @{$pg_users} ) {
                my $tmp = $db;
                $tmp =~ s/_//g;
                print {$pg_grants} "GRANT ALL ON DATABASE ${user}_${tmp} TO ${user}_${pg_user}\;\n";
            }
        }
    }

    ### enable create psql user/pass
    ## FIXME: this used to redefine $user (now $_user). When listuserpasswds(...) returned
    ##   blank info, the ...$user/psql_users.sql file would not be opened.
    ## Now that we are opening on $work_dir, the file is new. And has blank-ish
    ##   information. But, I feel the below is more correct.
    foreach my $pg_user (@pg_users) {
        my $passwd = listuserspasswds($pg_user);
        my $_user  = $user . '_' . $passwd->[0];
        my $_pass  = $passwd->[1];
        if ( open( my $fh, '>>', "$work_dir/psql_users.sql" ) ) {
            print {$fh} "CREATE USER $_user WITH PASSWORD '$_pass'\;\n";
        }
    }
    print "Done\n";

    ### copy homedir (fork code)
    print "pXa Copying homedir....";
    if ( my $pid = fork() ) {
        my $dotcount = 5;
        while ( waitpid( $pid, 1 ) != -1 ) {
            if ( $dotcount % 5 == 0 ) {
                print ".........\n";
            }
            sleep(1);
            $dotcount++;
        }
    }
    else {
        diskcheck();
        if ( chdir($homedir) ) {
            diskcheck();
            my @dirs = qw(
              anon_ftp bin cgi-bin conf error_docs httpsdocs private
              subdomains bin conf httpdocs pd statistics web_users
            );

            my $dirs_to_copy = join( ' ', grep { -d $_ } @dirs );

            system("tar -cf - $dirs_to_copy | ( cd $work_dir/homedir; tar -xf - )");
        }
        else {
            print "Can not copy homedir\n";
        }
        exit();
    }
    print "Done\n";

    _clean_up_homedir_copy($work_dir);

    collect_protected_dirs( $domainid, $work_dir, $homedir );

    ### loop on @WEBUSERS, clean up homedir copy
    foreach my $webuser (@WEBUSERS) {
        $webuser = clean_username( $webuser, 0 );
        system("mv $work_dir/homedir/public_html/$webuser $work_dir/homedir/public_html/$webuser.old 2>/dev/null");
        system( "mv", "$work_dir/homedir/web_users/$webuser", "$work_dir/homedir/public_html/$webuser" );
    }

    ### create secure subdomain
    if ( -d "$work_dir/homedir/httpsdocs" ) {
        if ( open( my $fh, '>>', "$work_dir/sds" ) ) {
            print {$fh} 'secure.' . $lcdns . "\n";
            close $fh;
        }
        if ( open( my $fh, '>>', "$work_dir/sds2" ) ) {
            print {$fh} 'secure_' . $lcdns . '=' . 'httpsdocs' . "\n";
            close $fh;
        }
    }

    ### copy subdomains
    opendir( my $sub_h, "$homedir/subdomains" );
    my @sub_dirs = grep { !/^\.\.?/ } readdir($sub_h);
    close $sub_h;
    if ( scalar @sub_dirs ) {
        print 'Copying subdomains...';
        mkdir( "$work_dir/homedir/subdomains", 0755 );
        if ( open( my $sds_h, ">>$work_dir/sds" ) ) {
            foreach my $sub (@sub_dirs) {
                print {$sds_h} $sub . '.' . $lcdns . "\n";
                if ( open( my $sds2_h, ">>$work_dir/sds2" ) ) {
                    print {$sds2_h} $sub . '_' . $lcdns . '=subdomains/' . $sub . "/httpdocs\n";
                    close $sds2_h;
                }
                diskcheck();
                system( 'cp', $cpflags, "$homedir/subdomains/$sub/httpdocs", "$work_dir/homedir/subdomains/$sub" );
            }
        }
        print "Done\n";
    }

    ### copy parked domains
    print "Copying parked domains...";
    my $parks = parks( $clientid, $user );
    if ( open( my $pds_fh, '>>', "$work_dir/pds" ) ) {
        if ( open( my $htaccess_fh, '>>', "$work_dir/homedir/public_html/.htaccess" ) ) {
            print {$htaccess_fh} "RewriteEngine on\n\n";
            foreach my $park (@$parks) {
                print {$pds_fh} $park->[0] . "\n";
                if ( $park->[1] ne 'NULL' ) {
                    print {$htaccess_fh} write_redirect_htaccess( $lcdns, $park->[1] ) . "\n";
                }
            }
        }
    }
    print "Done\n";

    ### copy mail (fork code)
    print "pXa Copying mail....";
    if ( my $pid = fork() ) {
        my $dotcount = 5;
        while ( waitpid( $pid, 1 ) != -1 ) {
            if ( $dotcount % 5 == 0 ) {
                print ".........\n";
            }
            sleep(1);
            $dotcount++;
        }
    }
    else {
        my $poppasswd = mail_pass($domainid);
        foreach my $name (@POPS) {
            my $cpname = lc($name);

            ## pek FIXME: still think @domain is just ($dns)
            foreach my $domain (@domains) {
                my $lc_domain = lc $domain;

                if ( -e "${maildir}/mailnames/${domain}/${name}/Maildir" ) {
                    diskcheck();
                    system( 'mkdir', '-p', "$work_dir/homedir/mail/$lc_domain/" );
                    system( "cp", "$cpflags", "${maildir}/mailnames/${domain}/${name}/Maildir", "$work_dir/homedir/mail/${lc_domain}/${cpname}" );

                    my ( $cpass, $quota ) = _get_cpass( $poppasswd, $name, $domain );
                    if ($cpass) {
                        open( PASSWD, ">>$work_dir/homedir/etc/${lc_domain}/passwd" );
                        print PASSWD "${cpname}:x:-1:-1::/home/${cpuser}/mail/${lc_domain}/${cpname}:/usr/local/cpanel/bin/noshell\n";
                        close(PASSWD);
                        chmod( 0640, "$work_dir/homedir/etc/${lc_domain}/shadow" );
                        open( PASSWD, ">>$work_dir/homedir/etc/${lc_domain}/shadow" );
                        print PASSWD "${cpname}:${cpass}:::::::\n";
                        close(PASSWD);
                        chmod( 0600, "$work_dir/homedir/etc/${lc_domain}/shadow" );
                    }
                    if ( $quota && $quota ne '-1' ) {
                        if ( open( my $fh, '>>', "$work_dir/homedir/etc/${lc_domain}/quota" ) ) {
                            print {$fh} "$cpname:$quota\n";
                            close $fh;
                        }
                    }
                }
            }
        }
        exit(0);
    }

    ## pek FIXME: is there a chdir somewhere before this???
    ### create symlinks
    symlink( "public_html/cgi-bin", "$work_dir/homedir/cgi-bin" );
    symlink( "public_ftp",          "$work_dir/homedir/anon_ftp" );

    ## FIXME note: based on the prior usage of lexical scope of all '$domain' variables,
    ##   this was always going to be undef at this point...
    my $domain;
    symlink( "/usr/local/apache/domlogs/${domain}", "$work_dir/homedir/logs/access_log" );

    ### copy cpuser file (via mysql)
    print "pXa Copying cpuser file.......";

    my $create_time = psasqlcmd("SELECT cr_date FROM domains WHERE name='$dns'");
    my $timestamp;
    if ($create_time) {
        my ( $year, $month, $day ) = split /-/, $create_time;
        $timestamp = Time::Local::timelocal( 0, 0, 0, $day, $month - 1, $year - 1900 );
    }
    my $account_limits = get_account_limits($dns);
    open( CPU, ">$work_dir/cp/${cpuser}" );
    print CPU "DNS=${lcdns}\n";
    print CPU "STARTDATE=${timestamp}\n" if $timestamp;
    foreach my $key (qw/MAXSUB MAXADDON MAXLST MAXSQL MAXFTP MAXPARK MAXPOP/) {
        print CPU "$key=" . $account_limits->{$key} . "\n";
    }
    close(CPU);
    print "Done\n";

    print "pXa Copying ftp quota......";
    if ( open( my $fh, '>', "$work_dir/homedir/etc/quota" ) ) {
        print {$fh} "$cpuser: $account_limits->{'mbox_quota'}\n";
    }
    print "Done\n";

    ### copy quote info (via mysql)
    print "pXa Copying quota info.......";
    open( QUOTA, ">$work_dir/quota" );

    my $quota = psaquotas( $psaversion, $dns, $domainid );
    print QUOTA "$quota";
    close(QUOTA);
    print "Done\n";

    system("find $work_dir/homedir/ -type d -exec chmod -R 755 {} ';'");
    system("find $work_dir/homedir/ -type f -exec chmod -R 644 {} ';'");
    ## pek FIXME: per note above, there is at least a chdir here
    ### creating archive: the split code
    if ( chdir("${tarroot}") ) {
        print "Creating Archive ....";
        my $parts    = [];
        my $splitdir = "${work_dir}-split";

        if ($nosplit) {
            if ( my $pid = fork() ) {
                my $dotcount = 5;
                while ( waitpid( $pid, 1 ) != -1 ) {
                    if ( $dotcount % 5 == 0 ) {
                        print ".........\n";
                    }
                    sleep(1);
                    $dotcount++;
                }
            }
            else {
                system( "tar", "pczf", "${prefix}${cpuser}.tar.gz", "${prefix}${cpuser}" );
                exit();
            }
        }
        else {
            $parts = splittar(
                {
                    source      => "${prefix}${cpuser}",
                    destination => $splitdir,
                    tarname     => "${prefix}${cpuser}",
                    splitname   => "${prefix}${cpuser}.tar.gz",
                    system      => $system,
                }
            );
        }

        ### clean up after self
        ## pek: no longer needed, because of split files?
        if ( -d $work_dir && !-l $work_dir ) {
            system( "rm", "-rf", $work_dir );
        }
        print "Done\n";

        ### output user and pkgacct file locations
        print "realusername is: $cpuser\n";
        if ( !$nosplit && @{$parts} ) {
            foreach my $part ( @{$parts} ) {
                print "splitpkgacctfile is: $splitdir/${part}\n";
                my $md5sum = md5( "$splitdir/${part}", $system );
                print "splitmd5sum is: $md5sum\n";
            }
        }
        else {
            print "pkgacctfile is: $work_dir.tar.gz\n";
            my $md5sum = md5( "$work_dir.tar.gz", $system );
            print "md5sum is: $md5sum\n";
        }
        return undef;
    }
    else {
        die "Unable to create archive\n";
    }
}

## note: implemented as two separate get_ and set_ methods to ensure you
##   could actually set to an undef or false value.
{
    my $_psa1;

    sub get_psa1 {
        return $_psa1;
    }

    sub set_psa1 {
        my ($val) = @_;
        $_psa1 = $val;
        return undef();
    }
}

## note: refactor eventually; could be more generically useful
sub get_horde_tables {
    my $mysql = find_mysql();

    my $dbh = "mysql -s --skip-column-names horde";
    my $cmd = 'SHOW TABLES';
    IPC::Open3::open3( my $write, my $read, my $err, $dbh );

    print $write "$cmd\n";
    close $write;
    my %tables;
    while ( my $line = <$read> ) {
        chomp($line);
        $tables{$line} = 1;
    }
    close $read;

    return \%tables;
}

#
# Read in an existing AWstats configuration file, and output a new one in the
# location specified, containing modifications that will make the configuration
# file suitable for use in a cPanel environment.
#
sub create_patched_awstats_conf {
    my ( $existing, $new, $args ) = @_;

    # tidyoff -- perltidy does not align conditionals properly here
    die('Arguments not supplied as a hash')    unless ref($args) eq 'HASH';
    die('No cPanel username specified')        unless defined $args->{'cpuser'};
    die('No HTTP log file location specified') unless defined $args->{'logfile'};
    die('No site domain specified')            unless defined $args->{'domain'};
    # tidyon
    unless ( defined $args->{'aliases'} && ref( $args->{'aliases'} ) eq 'ARRAY' ) {
        die('No domain aliases specified');
    }

    my %substitutions = (
        'DirCgi'                    => '/tmp/awstats',
        'DirIcons'                  => '/images/awstats',
        'DirLang'                   => '/usr/local/cpanel/3rdparty/share/awstats/lang',
        'LinkToWhois'               => 'http://www.whois.net/search.cgi2?str=',
        'LogFile'                   => $args->{'logfile'},
        'SiteDomain'                => $args->{'domain'},
        'DirData'                   => "/home/$args->{'cpuser'}/tmp/awstats",
        'AllowFullYearView'         => 3,
        'HostAliases'               => join( ' ', @{ $args->{'aliases'} } ),
        'LevelForKeywordsDetection' => undef,
        'MiscTrackerUrl'            => undef
    );

    open( my $existing_fh, '<', $existing ) or die("Unable to open existing AWstats config file $existing: $!");
    open( my $new_fh,      '>', $new )      or die("Unable to open new AWstats config file $new for writing: $!");

    while ( my $line = readline($existing_fh) ) {
        chomp($line);

        #
        # If we've found a non-comment, non-whitespace line that looks like an
        # assignment, such as the following...
        #
        #     LogFile = "/var/www/access.log"
        #
        # ...then, using the name portion parsed out from the string, check to
        # see if any substitutions for the values listed in the configuration
        # file exists.  Note that an undef is used as a means of dropping a
        # declaration from the configuration file altogether, as necessary.
        #
        # If the line does not appear to be a declaration for which we have a
        # substitute, then the line is simply repeated as-is into the patched
        # configuration file.
        #
        if ( $line =~ /^\s*([^=\s]+)\s*=/ && exists $substitutions{$1} ) {
            next unless defined $substitutions{$1};

            print {$new_fh} qq($1 = "$substitutions{$1}"\n);
        }
        else {
            print {$new_fh} "$line\n";
        }
    }

    close($new_fh);
    close($existing_fh);
}

## note re: the global var $psa1. There are 18 invocations of this function. Aside from
##   the new &script, there are 7 methods that call this. I wanted to parameterize $psa1,
##   but I don't want to have to pass it around to 7 other methods...
sub psasqlcmd {
    my ($cmd) = @_;
    my ($result);

    my $psa1 = get_psa1();

    my $mysql = find_mysql();
    ## -N: skip column names in output
    if ($psa1) {
        IPC::Open3::open3( \*WTRFH, \*RDRFH, '', "$mysql -N plesk" );
    }
    else {
        IPC::Open3::open3( \*WTRFH, \*RDRFH, '', "$mysql -N psa" );
    }
    print WTRFH "$cmd\n";
    close(WTRFH);
    while (<RDRFH>) {
        $result .= $_;
    }
    close(RDRFH);

    return ($result);
}

sub find_mysql {
    my ($self) = @_;
    my ( @LOC, $loc );
    @LOC = ( "/usr/local/psa/mysql/bin/mysql", "/usr/bin/mysql", "/usr/sbin/mysql", "/usr/local/plesk/mysql/bin/mysql", "/usr/local/bin/mysql" );
    foreach $loc (@LOC) {
        if ( -e $loc ) { return $loc; }
    }
}

sub getpsasysuid {
    my ( $user, $psaversion ) = @_;
    my $sysuserid;

    if ( $psaversion >= 5 ) {
        print "Fetching psa userid using v5 method\n";
        $sysuserid = psasqlcmd("select id from sys_users where login='$user';");
        print "v5 PSA UID: $sysuserid\n";
    }

    if ( $sysuserid eq "" || $sysuserid == 0 ) {
        $sysuserid = ( getpwnam($user) )[2];
        $sysuserid = ( $sysuserid - 10000 );
    }

    print "PSA UID: $sysuserid\n";
    return ($sysuserid);
}

## pek NOTE: redef &getpsadir in tests
sub getpsaversion {
    my $psadir  = getpsadir();
    my $version = undef;         # Defaults to 'undef' to denote an unsupported version

    ## pek NOTE: see /tmp/.../version
    open( PSAV, "${psadir}/version" );
    while (<PSAV>) {
        if (/^10/) { $version = 10; }
        if (/^9/)  { $version = 9; }
        if (/^8/)  { $version = 8; }
        if (/^7/)  { $version = 7; }
        if (/^6/)  { $version = 6; }
        if (/^5/)  { $version = 5; }
    }
    close(PSAV);

    return ($version);
}

## pek NOTE: /usr/local/psa
sub getpsadir {
    my ( @LOC, $loc );
    @LOC = ( "/usr/local/psa", "/usr/local/plesk", "/opt/psa" );
    foreach my $loc (@LOC) {
        if ( -e $loc ) { return $loc; }
    }
}

sub clean_username {
    my ( $cpuser, $truncate ) = @_;

    $cpuser =~ s/[^a-zA-Z0-9.-]//g;
    $cpuser =~ s/[.]+/./g;
    $cpuser =~ s/[_]//g;
    $cpuser = lc $cpuser;

    if ($truncate) {
        $cpuser = substr $cpuser, 0, 8;
    }

    return $cpuser;
}

sub fork_code {
    my ($args) = @_;
    if ( ref( $args->{'code'} ) ne 'CODE' ) {
        print 'Argument not a code ref' . "\n";
        exit(1);
    }

    if ( ( exists $args->{'args'} ) && ( ref $args->{'args'} ne 'ARRAY' ) ) {
        print 'args must be an array ref.' . "\n";
        exit(1);
    }

    my $user   = $args->{'user'} || '';
    my $code   = $args->{'code'};
    my $wait   = $args->{'wait'} ? 1 : 0;
    my $dots   = $args->{'dots'} ? 1 : 0;
    my $stdout = $args->{'stdout'} ? $args->{'stdout'} : '/dev/null';
    my @args   = exists $args->{'args'} ? @{ $args->{'args'} } : ();

    my ( $uid, $gid ) = ( getpwnam($user) )[ 2, 3 ];

    my $pid;
    if ( $pid = fork() ) {
        my $dotcount = 5;
        if ($wait) {
            while ( waitpid( $pid, 1 ) != -1 ) {
                if ( $dotcount % 5 == 0 ) {
                    print "\t" . ".........\n" if $dots;
                }
                sleep(1);
                $dotcount++;
            }
        }
    }
    else {
        if ( defined $uid && $< == 0 ) {
            $< = int $uid;
            $> = int $uid;
            $( = int $gid;
            $) = "$gid $gid";
        }
        open( STDIN,  '<', '/dev/null' );
        open( STDOUT, '>', $stdout );
        open( STDERR, '>', '/dev/null' );

        $code->(@args);
        exit;
    }
}

sub _set_binding {
    my ( $stmt, @bind ) = @_;

    # Count the number of question-marks in the statement
    my $bind_count = 0;
    $bind_count++ while ( $stmt =~ /(\?)/g );

    # The number of question-marks and the number of elements in the array must match
    if ( ( scalar @bind > 0 ) and ( $bind_count == scalar @bind ) ) {
        foreach my $binding (@bind) {
            $binding = quote($binding);
            $stmt =~ s/\?/$binding/;
        }
        return $stmt;
    }

    return $stmt;
}

sub _access_db {
    my ($args) = @_;

    croak('Hash ref must be passed') if ref $args ne 'HASH';

    my $psql             = find_psql();
    my $db               = $args->{'db'} || 'template1';
    my $stmt             = $args->{'stmt'};
    my $tuples_only      = ( exists $args->{'tuples_only'} ) ? '-t' : '';
    my $record_separator = '-+++-';

    my ( $pid, $psqlres, $psql_h );
    if ($tuples_only) {
        $pid = IPC::Open3::open3( $psql_h, $psqlres, '', $psql, $tuples_only, '-A', '-R', $record_separator, $db );
    }
    else {
        $pid = IPC::Open3::open3( $psql_h, $psqlres, '', $psql, '-A', '-R', $record_separator, $db );
    }

    if ($pid) {
        print {$psql_h} $stmt;
        close $psql_h;

        my $str_results;
        while ( my $output = <$psqlres> ) {
            $str_results .= $output;
        }
        close $psqlres;
        return $str_results;
    }
}

sub _create_arrayref {
    my ($string_data) = @_;

    my $record_separator_qr = qr{\Q-+++-};

    my @results = ();
    my @records = split m{$record_separator_qr}, $string_data;

    chomp @records;

    foreach my $record (@records) {
        push @results, [ split /\|/, $record ];
    }

    return \@results;

}

sub pg_fetch_array_string {
    my ( $db, $stmt, @bind ) = @_;

    my $record_separator = '-+++-';

    $stmt = _set_binding( $stmt, @bind );

    my $str_data = _access_db( { db => $db, stmt => $stmt, tuples_only => 1 } );

    return if !$str_data;
    if ( $str_data =~ m/[^\:]+\:\s+could\s+not\s+connect/i ) {
        print STDERR "PostgreSQL Server is down or unreachable\n";
        return;
    }

    return if !$str_data;
    return $str_data;
}

sub _create_hashref {
    my ($string_data) = @_;

    my $record_separator_qr = qr{\Q-+++-};

    my @records = split m{$record_separator_qr}, $string_data;

    chomp @records;
    pop @records;

    my @field_names = map lc, split( /\|/, shift(@records) );

    my @result_set;
    foreach my $row (@records) {
        my @row = split /\|/, $row;

        my $results = {};
        my $count   = 0;
        foreach my $field (@field_names) {
            $results->{$field} = $row[$count];
            $count++;
        }

        push @result_set, $results;
    }

    return \@result_set;
}

sub pg_fetch_hashref {
    my ( $db, $stmt, @bind ) = @_;

    my $user             = pg_user();
    my $record_separator = '-+++-';

    $stmt = _set_binding( $stmt, @bind );

    my $str_data = _access_db( { stmt => $stmt } );

    return if !$str_data;

    if ( $str_data =~ m/[^\:]+\:\s+could\s+not\s+connect/i ) {
        print STDERR "PostgreSQL Server is down or unreachable\n";
        return;
    }
    return $str_data;
}

sub quote {
    my ($string) = @_;

    for ($string) {
        s/\\/\\\\/go;     # Escape forward slashes
        s/\0/\\0/go;      # Escape nulls
        s/\n/\\n/go;      # Escape newlines
        s/\r/\\r/go;      # Escape carriage returns
        s/'/\\'/go;       # Escape single quotes
        s/"/\\"/go;       # Escape double quotes
        s/\x1a/\\Z/go;    # Escape Ctrl-Z which is EOF in windows text mode
    }

    return qq{'$string'};
}

sub find_psql {
    my ($self) = @_;
    my $loc = "";
    my @LOC = ( "/usr/bin/psql", "/usr/local/bin/psql" );
    foreach $loc (@LOC) {
        if ( -e $loc ) { return $loc; }
    }
    return ($loc);
}

sub find_pg_dump {
    my ($self) = @_;
    my $loc = "";
    my @LOC = ( "/usr/bin/pg_dump", "/usr/local/bin/pg_dump" );
    foreach $loc (@LOC) {
        if ( -e $loc ) { return $loc; }
    }
    return ($loc);
}

sub find_pgdb_user {
    my ($db) = @_;

    my ($pg_user) = pg_pass();
    pipe( my $parent_rdr, my $child_wtr );
    $parent_rdr->autoflush(1);

    fork_code(
        {
            user => $pg_user,
            wait => 1,
            dots => 1,
            code => sub {
                my @pg = _getpwnam($pg_user);
                local $ENV{'PGUSER'} = $pg[0];
                local $ENV{'HOME'}   = $pg[7];
                my ($child_wtr) = @_;
                close $parent_rdr;

                my $data = pg_fetch_array_string( $db, <<SQL);
SELECT
  u.usename as "Owner"
FROM pg_catalog.pg_class c
     LEFT JOIN pg_catalog.pg_user u ON u.usesysid = c.relowner
     LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
WHERE c.relkind IN ('r','v','S','')
      AND n.nspname NOT IN ('pg_catalog', 'pg_toast')
      AND pg_catalog.pg_table_is_visible(c.oid)
SQL

                print {$child_wtr} $data;
                close $child_wtr;
            },
            args => [$child_wtr],
        }
    );
    close $child_wtr;

    my $data;
    while (<$parent_rdr>) {
        $data .= $_;
    }
    close $parent_rdr;
    $data = _create_arrayref($data);
    return $data->[0];
}

sub listuserspasswds {
    my ($user)    = @_;
    my ($pg_user) = pg_pass();
    pipe( my $parent_rdr, my $child_wtr );
    $parent_rdr->autoflush(1);

    fork_code(
        {
            user => $pg_user,
            wait => 1,
            dots => 1,
            code => sub {
                my @pg = _getpwnam($pg_user);
                local $ENV{'PGUSER'} = $pg[0];
                local $ENV{'HOME'}   = $pg[7];
                my ($child_wtr) = @_;
                close $parent_rdr;

                my $data = pg_fetch_array_string( 'template1', 'SELECT usename, passwd FROM pg_shadow WHERE usename = ?', $user );
                print {$child_wtr} $data;
                close $child_wtr;
            },
            args => [$child_wtr],
        }
    );
    close $child_wtr;

    my $data;
    while (<$parent_rdr>) {
        $data .= $_;
    }
    close $parent_rdr;
    $data = _create_arrayref($data);
    return $data->[0];
}

sub mysqldumpdb {
    my ($args) = @_;

    my @options   = @{ $args->{'options'} };
    my $db        = $args->{'db'};
    my $table     = $args->{'table'};
    my $file      = $args->{'file'};
    my $file_mode = $args->{'append'} ? '>>' : '>';

    my $mysqldump = find_mysqldump();

    if ( !-e $mysqldump ) {
        print "Unable to backup mysql database $db\n";
        return;
    }
    my @db = ($db);
    if ($table) {
        push @db, $table;
    }
    print join( '.', @db ) . ' ';
    my $pid = IPC::Open3::open3( my $w, my $r, '', $mysqldump, @options, @db );

    my $first_line = 1;
    if ( open( my $fh, $file_mode, $file ) ) {
        use bytes;
        while (<$r>) {
            if ( $first_line && ( !$_ || m/^mysqldump:/ ) ) {
                warn join( '.', @db ) . ': ' . $_;
                close $w;
                close $r;
                waitpid( $pid, 0 );
                $first_line = 0;
                my $mysqlcheck = find_mysqlcheck();
                system( $mysqlcheck, '--repair', @db );
                $pid = IPC::Open3::open3( $w, $r, '', $mysqldump, @options, @db );
            }
            else {
                print {$fh} $_;
            }
        }
        no bytes;
    }
    close $w;
    close $r;
    waitpid( $pid, 0 );
}

sub find_mysqldump {
    my ( @LOC, $loc );
    @LOC = ( "/usr/bin/mysqldump", "/usr/local/bin/mysqldump" );
    foreach $loc (@LOC) {
        if ( -e $loc ) { return $loc; }
    }
}

sub find_mysqlcheck {
    my ( @LOC, $loc );
    @LOC = ( "/usr/bin/mysqlcheck", "/usr/local/bin/mysqlcheck" );
    foreach $loc (@LOC) {
        if ( -e $loc ) { return $loc; }
    }
}

sub mysql_quote {
    my ($string) = @_;

    for ($string) {
        s/_/\\\\_/go;
    }
    return $string;
}

sub domainid {
    my ( $psaversion, $dns, $sysuserid, $user ) = @_;

    if ( $psaversion >= 7 ) {
        return psasqlcmd("select id from domains where name='$dns';");
    }
    elsif ( $psaversion == 6 ) {
        return psasqlcmd("select dom_id from hosting where sys_user_id='$sysuserid';");
    }
    elsif ( $psaversion == 5 ) {
        return psasqlcmd("select hosting.dom_id from hosting left join sys_users on hosting.sys_user_id=sys_users.id where sys_users.login='$user';");
    }
    else {
        return psasqlcmd("select dom_id from hosting where login='$user';");
    }
}

sub clientid {
    my ($domainid) = @_;
    return psasqlcmd("SELECT cl_id FROM domains WHERE id = $domainid");
}

sub db_users {
    my ( $domainid, $type ) = @_;
    my @users = split( /\n/, psasqlcmd("SELECT db_users.login FROM db_users INNER JOIN data_bases ON data_bases.id = db_users.db_id INNER JOIN domains ON data_bases.dom_id = domains.id WHERE data_bases.type='$type' and domains.id = $domainid") );
    return @users;
}

sub dbs {
    my ( $domainid, $type ) = @_;
    my @dbs = split( /\n/, psasqlcmd("select name from data_bases where dom_id='$domainid' and type='$type'") );
    return @dbs;
}

sub pg_pass {
    my $line = psasqlcmd("SELECT admin_login, admin_password FROM DatabaseServers WHERE type='postgresql'");
    my ( $user, $pass ) = split /\s+/, $line;
    my ( $homedir, $uid, $gid ) = ( getpwnam($user) )[ 7, 2, 3 ];
    if ( -e $homedir ) {
        if ( !-e "$homedir/.pgpass" ) {
            if ( open( my $fh, '>', "$homedir/.pgpass" ) ) {
                print {$fh} '*:*:*:' . $user . ':' . $pass;
                close($fh);
            }
            chown( $uid, $gid, "$homedir/.pgpass" );
            chmod( 0600, "$homedir/.pgpass" );
        }
    }
    return ( $user, $pass );
}

sub _salt {
    srand(time);
    my @chars = ( 'a' .. 'z', 'A' .. 'Z', 0 .. 9, qw(! @ $ ^ & * ) );
    my $salt = join( '', @chars[ map { rand @chars } ( 1 .. 8 ) ] );
    return '$1$' . $salt . '$';
}

sub mail_pass {
    my ($domainid) = @_;
    my $salt = _salt();

    my @passwd;

    ## there is no roadmap to what the 'cl_' stands for, but this seems like a
    ## parent/child structure. like cl_id is the parent id of $domainid.
    my $cl_id = psasqlcmd("SELECT cl_id FROM domains WHERE id = $domainid");

    my $_domains_sql = "SELECT id FROM domains WHERE cl_id = $cl_id";
    my @domains      = split( /\n/, psasqlcmd($_domains_sql) );
    my $domains      = join ',', @domains;

    my $_sql = "
SELECT mail.mail_name, accounts.type,
  ENCRYPT(accounts.password, '$salt') AS crypt, accounts.password AS plain,
  domains.name, mail.mbox_quota
FROM mail INNER JOIN accounts ON mail.account_id = accounts.id,
  domains
WHERE mail.dom_id IN ($domains)
  AND mail.dom_id = domains.id";

    my $_cmd_out = psasqlcmd($_sql);
    my @output = split( /\n/, $_cmd_out );
    foreach my $line (@output) {
        my @pw;
        push @pw, split( /\s+/, $line );
        if ( $pw[1] eq 'plain' ) {
            push @passwd, sprintf "%s:%s:%s:%s", $pw[0], $pw[2], $pw[-2], $pw[-1];
        }
        else {
            push @passwd, sprintf "%s:%s:%s:%s", $pw[0], $pw[3], $pw[-2], $pw[-1];
        }
    }
    return \@passwd;
}

sub mysqlversion {
    my $version = psasqlcmd("SELECT VERSION()");
    if ( $version =~ /^(\d+\.\d+)\.\d+/ ) {
        return $1 if $1;
    }
}

sub splittar {
    my ($args) = @_;

    my $source      = $args->{'source'};
    my $destination = $args->{'destination'};
    my $tarname     = $args->{'tarname'};
    my $splitname   = $args->{'splitname'};
    my $system      = $args->{'system'};

    if ( -d $source ) {
        mkdir( $destination, 0700 );
        rename( $source, "$destination/$tarname" );
        chdir($destination) || die 'Unable to change into ' . $destination;
    }
    else {
        die 'The source: ' . $source . ' is not a directory';
    }

    my $it = make_splitfile_iter(
        {
            read_limit  => 3000000,
            bytes_limit => 10000000,
            dir         => $tarname,
            system      => $system,
        }
    );

    my $count = 1;
    while ( my $chunk = $it->() ) {
        my $file = sprintf( "%s%05d", "$splitname.part", $count );
        if ( open( my $fh, '>', $file ) ) {
            print {$fh} $chunk;
            $count++;
            close $fh;
        }
        print '.......' . "\n";
    }
    system( 'rm', '-rf', $tarname );
    opendir( my $dir_h, $destination );
    my @files = grep { !/^\.\.?$/ } readdir $dir_h;
    return \@files;
}

sub make_splitfile_iter {
    my ($args)      = @_;
    my $read_limit  = $args->{'read_limit'};
    my $bytes_limit = $args->{'bytes_limit'};
    my $dir         = $args->{'dir'};
    my $system      = $args->{'system'};

    my ( $pid, $tar_w, $tar_r, $tar_e );
    if ( $system =~ /freebsd/i ) {
        $pid = IPC::Open3::open3( $tar_w, $tar_r, $tar_e, 'tar', 'pczf', '-', $dir );
    }
    else {
        $pid = IPC::Open3::open3( $tar_w, $tar_r, $tar_e, 'tar', 'pcz', $dir );
    }

    if ($pid) {
        close $tar_w;
        return sub {
            my $store;
            my $bytes = 0;
            while ( my $bytes_read = read( $tar_r, my $buffer, $read_limit ) ) {
                $bytes += $bytes_read;
                $store .= $buffer;
                if ( $bytes > $bytes_limit ) {
                    return $store;
                }
                elsif ( eof($tar_r) ) {
                    return $store;
                }
            }
        };
    }
}

sub md5 {
    my ( $file, $system ) = @_;
    my $md5sum;

    if ( $system =~ /freebsd/i ) {
        chomp( $md5sum = `md5 -r "$file"` );
    }
    else {
        chomp( $md5sum = `md5sum "$file"` );
    }
    $md5sum =~ /^(\S+)[\s|\t]*/;
    $md5sum = $1;
    return $md5sum;
}

sub df_mount {
    my ($mount) = @_;
    $mount ||= '/home';

    IPC::Open3::open3( my $df_h, my $df_res, '', 'df', '-P', $mount );
    close $df_h;

    my $buffer;
    while ( my $line = <$df_res> ) {
        $buffer .= $line;
    }

    my @lines = split( "\n", $buffer );
    for my $line (@lines) {
        if ( $line =~ /^(\S+)\s*\d*\s*\d*\s*\d*\s*(\d*)\%\s*(\S+)/ ) {
            my $dev   = $1;
            my $per   = $2;
            my $mount = $3;
            ## Look for block or character special file, or specifically a
            ##   Virtuozzo filesystem
            if ( !-l $dev && ( -b _ || -c _ || $dev eq 'vzfs' ) ) {
                my $disk = $dev;
                $disk =~ s/^.+\///;
                return {
                    'disk'       => $disk,
                    'percentage' => $per,
                    'mount'      => $mount,
                };
            }
        }
    }
    return;
}

sub diskcheck {
    my $df = df_mount();
    return unless ( defined $df );

    if ( $df->{'percentage'} >= 98 ) {
        print 'RUNNING LOW ON DISKSPACE!!!' . "\n";
        print 'Diskusage at ' . $df->{'percentage'} . '%' . "\n";
    }
}

sub find_tarroot {
    my ($tarroot) = @_;
    if ( $tarroot eq "" || !-d $tarroot ) {
        $tarroot = '/home';
    }
    return $tarroot;
}

## dep fs side-effects: create &_system which delegates; test redef
## dep fs side-effects: test untars to /tmp and passes in "/tmp"
sub _clean_up_homedir_copy {
    my ($work_dir) = @_;
    system( "rm", "-f", "$work_dir/homedir/logs/access_log" );
    system( "mv", "$work_dir/homedir/httpdocs", "$work_dir/homedir/public_html" );
    system("mv $work_dir/homedir/public_html/cgi-bin $work_dir/homedir/public_html/cgi-bin.old 2>/dev/null");
    system( "mv", "$work_dir/homedir/cgi-bin",  "$work_dir/homedir/public_html/cgi-bin" );
    system( "mv", "$work_dir/homedir/anon_ftp", "$work_dir/homedir/public_ftp" );

    system( "mv", "$work_dir/homedir/error_docs/bad_request.html", "$work_dir/homedir/public_html/400.shtml" );
    symlink( "$work_dir/homedir/error_docs/bad_request.html", "../public_html/400.shtml" );
    system( "mv", "$work_dir/homedir/error_docs/forbidden.html", "$work_dir/homedir/public_html/403.shtml" );
    symlink( "$work_dir/homedir/error_docs/forbidden.html", "../public_html/403.shtml" );
    system( "mv", "$work_dir/homedir/error_docs/internal_server_error.html", "$work_dir/homedir/public_html/500.shtml" );
    symlink( "$work_dir/homedir/error_docs/internal_server_error.html", "../public_html/500.shtml" );
    system( "mv", "$work_dir/homedir/error_docs/not_found.html", "$work_dir/homedir/public_html/404.shtml" );
    symlink( "$work_dir/homedir/error_docs/not_found.html", "../public_html/404.shtml" );
    return undef;
}

#
# Synthesize a list of grants that should be used be created by default for any
# database that has a default user already created for it.  This method is written
# for the purpose of fulfilling cPanel's need for a database account that correlates
# with the cPanel account name, but uses PSA database information to generate this.
#
sub collect_mysql_default_grants {
    my ( $cpuser, $domain_id ) = ( $_[0], int( $_[1] ) );
    my @grants;

    #
    # First, grab a list of the databases, and the passwords of the main accounts
    # associated with them, for the current domain.
    #
    my $db_results = psasqlcmd_hashref(
        qq(
        select distinct
            db.name db_name,
            mysql_user.Password db_pass
        from
            psa.data_bases db,
            psa.db_users db_u,
            mysql.user mysql_user
        where
            mysql_user.User = db_u.login
            and db_u.db_id = db.id
            and db_u.id = db.default_user_id
            and db.type = 'mysql'
            and db.dom_id = $domain_id
        order by
            db_u.id
    )
    );

    return () unless ref($db_results) eq 'ARRAY';
    return () unless @{$db_results} > 0;

    #
    # Synthesize the first grant to be based on the first password found,
    # creating the initial default user account to be referenced by statements
    # granting privileges to users for the databases in question.
    #
    my $default_pass = $db_results->[0]->{'db_pass'};

    push @grants, qq(GRANT USAGE ON *.* TO '$cpuser'\@'localhost' IDENTIFIED BY PASSWORD '$default_pass';);

    #
    # Grant privileges to the default cPanel database user created above, for
    # each database found belonging to this Plesk account.
    #
    foreach my $db ( map { $_->{'db_name'} } @{$db_results} ) {
        push @grants, qq(GRANT ALL PRIVILEGES ON '$db'.* TO '$cpuser'\@'localhost';);
    }

    return @grants;
}

## dep db: unit testing database
## dep db: redef that returns lines
## dep db: further abstract where extract($db_user) returns grant repr.
sub collect_mysql_grants_for_user {
    my ($ra_db_users) = @_;
    my @mysql_grants;
    foreach my $db_user (@$ra_db_users) {
        my $host_line = _get_host_line_for($db_user);

        my @hosts = split /\n/, $host_line;
        foreach my $host (@hosts) {
            my $pid = IPC::Open3::open3(
                my ( $in, $out ), undef, qw(mysql mysql -B -ss --raw -e),
                qq(SHOW GRANTS FOR '$db_user'\@'$host';)
            );

            close($in);

            while ( my $line = readline($out) ) {
                chomp($line);

                next unless $line =~ /TO\s'($db_user)'@/;

                my $db_short = clean_mysql_username($1);
                $line =~ s/TO '$db_user'/TO '$db_short'/;

                push @mysql_grants, "$line;";

                #
                # To work around existing limitations in DB mapping, also add
                # a grant for 'localhost' if the current host is a glob.
                #
                if ( $host eq '%' ) {
                    $line =~ s/\@'%'/\@'localhost'/g;
                    push @mysql_grants, "$line;";
                }
            }

            waitpid( $pid, 0 );
            close($out);
        }
    }
    return @mysql_grants;
}

## dep db: unit testing database
## dep db: redef w/hash lookup that returns string
sub _get_host_line_for {
    my ($db_user) = @_;
    my $host_line = `mysql mysql -B -ss -e "SELECT host from user where user='$db_user'"`;
}

## dep fs: test untars
## def fs: test redef, returns ar
sub _collect_mailnames {
    my ( $maildir, $domain ) = @_;
    ### collect mailnames(?)
    opendir( MAILNAMES, "${maildir}/mailnames/${domain}" );
    my @NAMES = readdir(MAILNAMES);
    @NAMES = grep( !/^\./, @NAMES );
    closedir(MAILNAMES);
    return \@NAMES;
}

sub _push_mail_aliases_to_VAs {
    my ( $domain, $mailname, $ar_VAs ) = @_;

    my $sql_format = qq(
SELECT mail_aliases.alias
FROM (mail_aliases LEFT JOIN mail ON mail_aliases.mn_id = mail.id)
LEFT JOIN domains ON domains.id = mail.dom_id
where mail_name = '%s' and name = '%s');
    my $sql = sprintf( $sql_format, mysql_quote($mailname), mysql_quote($domain) );
    my $raw_alias = psasqlcmd($sql);
    if ( defined $raw_alias ) {
        my @alias = split( /\n/, $raw_alias );
        for my $alias (@alias) {
            $alias =~ s/\s*$//g;
            my $line = sprintf( "%s@%s: %s@%s\n", $alias, lc $domain, $mailname, $domain );
            push( @$ar_VAs, $line );
        }
    }
    return undef;
}

## dep fs: test untars and pass in '/tmp'
sub _push_distinct_mailnames_to_pops {
    my ( $maildir, $domain, $mailname, $ar_POPS ) = @_;
    if ( -e "$maildir/mailnames/${domain}/${mailname}/Maildir/" ) {
        if ( !grep { /$mailname/ } @$ar_POPS ) {
            push @$ar_POPS, $mailname;
        }
    }
    return undef;
}

## dep fs: test untars and pass in '/tmp'; verify POPS && VAs
sub _push_default_mailnames_to_VAs_POPS {
    my ( $maildir, $domain, $mailname, $ar_VAs, $ar_POPS ) = @_;
    my $lc_domain = lc $domain;

    open( DEFAULT, '<', "$maildir/mailnames/${domain}/${mailname}/.qmail" ) or die("Cannot open .qmail file: $!");
    my $forwards;
    while ( my $default = <DEFAULT> ) {
        chomp $default;
        if ( $default =~ /^\&/ ) {
            $default =~ s/^\&//g;
            $forwards = $default;
        }
        elsif ( $default eq "./Maildir/" or $default =~ /.\/Maildir/ ) {
            push( @$ar_POPS, $mailname );
        }
        if ($forwards) {
            push @$ar_VAs, "${mailname}\@${lc_domain}: $forwards\n";
        }
    }
    close(DEFAULT);
    return undef;
}

## dep fs: test pass in '/tmp', verify from untar
sub _output_VA_file {
    my ( $work_dir, $domain, $ar_VAs ) = @_;
    open( VA, ">$work_dir/va/${domain}" );
    map { print VA } @$ar_VAs;
    close(VA);
    return undef;
}

## dep fs: test untars and pass in '/tmp', verify rv
sub _define_default_from_qmail {
    my ( $maildir, $domain ) = @_;
    open( DEFAULT, "${maildir}/mailnames/${domain}/.qmail-default" );
    my $default;
    chomp( $default = <DEFAULT> );
    close(DEFAULT);
    return $default;
}

## dep vars: easy; pass in test vals, verify VAs
sub _process_default_to_VAs {
    my ( $default, $user, $ar_VAs ) = @_;
    if ( $default =~ /^\&/ ) {
        $default =~ s/^\&//g;
        push( @$ar_VAs, "*: $default\n" );
    }
    elsif ( $default =~ /bouncesaying \'([^\']+)\'/ ) {
        push( @$ar_VAs, "*: :fail: $1\n" );
    }
    else {
        push( @$ar_VAs, "*: ${user}\n" );
    }
    return undef;
}

sub _dump_horde_mysqldb {
    my ( $work_dir, $dns, $user ) = @_;

    my $hr_tables = get_horde_tables();

    my $horde_db       = "$work_dir/mysql/horde.sql";
    my @dns_regex_list = grep( !/(?:^www\.|\*)/i, $dns );
    my $dnslist        = join( '|', @dns_regex_list );
    $dnslist =~ s/\./\\./g;
    my @options = ( '-c', '-Q', '-q', '-t', '-w' );

    ## used for address books. does not currently work for "non-default" address books, as the
    ##   owner_id does not contain the domain. We might have better luck w/object_uid?)
    if ( exists $hr_tables->{'turba_objects'} ) {
        mysqldumpdb(
            {
                'options' => [ @options, qq{owner_id='$user' or owner_id REGEXP '@(${dnslist})\$'} ],
                'db'      => 'horde',
                'file'    => $horde_db,
                'table'   => 'turba_objects',
                'append'  => 1,
            }
        );
    }

    mysqldumpdb( { 'options' => [ @options, qq{pref_uid='$user' or pref_uid REGEXP '@(${dnslist})\$'} ], 'db' => 'horde', 'file' => $horde_db, 'table' => 'horde_prefs', 'append' => 1, } );

    ## pek: ticket 319961, removes the literal '@' from the event_uid, as 'webmail.' is prepended
    ## see above: (events calendar) better luck on secondaries w/event_creator_id?
    mysqldumpdb( { 'options' => [ @options, qq{event_uid='$user' or event_uid REGEXP '(${dnslist})\$'} ], 'db' => 'horde', 'file' => $horde_db, 'table' => 'kronolith_events', 'append' => 1, } );

    mysqldumpdb( { 'options' => [ @options, qq{vfb_owner='$user' or vfb_owner REGEXP '@(${dnslist})\$'} ], 'db' => 'horde', 'file' => $horde_db, 'table' => 'kronolith_storage', 'append' => 1, } );

    ## see above: (memos) better luck on secondaries w/memo_uid?
    mysqldumpdb( { 'options' => [ @options, qq{memo_owner='$user' or memo_owner REGEXP '@(${dnslist})\$'} ], 'db' => 'horde', 'file' => $horde_db, 'table' => 'mnemo_memos', 'append' => 1, } );

    print "...Done\n";
    return undef;
}

sub _get_cpass {
    my ( $poppasswd, $name, $domain ) = @_;

    my ( $cpass, $quota );
    foreach my $line (@$poppasswd) {
        my ( $_name, $_pass, $_domain, $_mailquota ) = split( /:/, $line );
        ## FIXME: match on \s*$name\s* instead? same w/$domain?
        ## ticket 319961: this was matching on /^$name/, regardless of domain. This could
        ##   copy over the wrong passwords. See the tests/ directory.
        if ( ( $_name eq $name ) and ( $_domain eq $domain ) ) {
            $cpass = $_pass;
            $quota = $_mailquota;
            ## FIXME: as we are now a tighter check, the last is
            ##   probably not necessary.
            last;
        }
    }
    return ( $cpass, $quota );
}

sub psaquotas {
    my ( $psaversion, $dns, $domainid ) = @_;
    my $quota;
    my $psa1 = get_psa1();
    if ( $psaversion >= 5 ) {
        $quota = ( ( psasqlcmd("select Limits.value from Limits, domains WHERE Limits.id = domains.limits_id AND domains.name = '${dns}' AND Limits.limit_name = 'disk_space';") ) / 1024 / 1024 );
    }
    elsif ($psa1) {
        $quota = ( ( psasqlcmd("select size from hosting where dom_id='${domainid}';") ) / ( 1024 * 1024 ) );
    }
    else {
        $quota = ( ( psasqlcmd("select size from domains where name='${dns}';") ) / ( 1024 * 1024 ) );
    }
    return $quota;
}

## Renaming and delegating so can be redefined in tests
sub _getpwnam {
    my ($user) = @_;
    my @getpwnam = getpwnam($user);
    return @getpwnam;
}

sub _get_adminpass {
    my ($psa1) = @_;
    if ($psa1) {
        open( PSAPASS, "/usr/local/plesk/admin/conf/admin.conf" );
    }
    else {
        open( PSAPASS, "$_etc/psa/.psa.shadow" );
    }

    my $adminpass = <PSAPASS>;
    chomp($adminpass);
    close(PSAPASS);
    return ( $psa1, $adminpass );
}

sub _compute_psa1 {
    my $psa1;
    if ( -e "$_etc/psa/.psa.shadow" ) {
        ## pass
    }
    else {
        $psa1 = 1;
    }
    return $psa1;
}

## pek NOTE: redef method, or redef '/root'
sub _create_my_cnf {
    my ($adminpass) = @_;
    open( RC, ">/root/.my.cnf" );
    print RC "[client]
user=admin
pass='$adminpass'\n";
    close(RC);
    chmod( 0600, "/root/.my.cnf" );
    return undef;
}

sub _copy_passwd_to_shadow {
    my ( $work_dir, $pass ) = @_;
    print "Copying password.......";
    open( SH, ">", "$work_dir/shadow" );
    chmod( 0600, "$work_dir/shadow" );
    print SH "$pass";
    close(SH);
    print "Done\n";
    return undef;
}

sub grab_crontab {
    my ($user) = @_;
    IPC::Open3::open3( my $writer, my $reader, '', 'crontab', '-u', $user, '-l' );
    close $writer;
    my $buffer = '';
    while ( my $line = <$reader> ) {
        $buffer .= $line;
    }
    close $reader;
    return $buffer;
}

sub get_zone {
    my ($domainid) = @_;
    my ( $name, $dns_zone_id ) = split( /\s+/, psasqlcmd("SELECT name, dns_zone_id FROM domains WHERE id = $domainid") );

    my $NS    = psasqlcmd_hashref("SELECT host, val FROM dns_recs WHERE dns_zone_id = $dns_zone_id AND type = 'NS'");
    my $A     = psasqlcmd_hashref("SELECT host, val FROM dns_recs WHERE dns_zone_id = $dns_zone_id AND type = 'A'");
    my $CNAME = psasqlcmd_hashref("SELECT host, val FROM dns_recs WHERE dns_zone_id = $dns_zone_id AND type = 'CNAME'");
    my $MX    = psasqlcmd_hashref("SELECT host, val, opt FROM dns_recs WHERE dns_zone_id = $dns_zone_id AND type = 'MX'");
    my $PTR   = psasqlcmd_hashref("SELECT host, val, opt FROM dns_recs WHERE dns_zone_id = $dns_zone_id AND type = 'PTR'");
    my $TXT   = psasqlcmd_hashref("SELECT host, val FROM dns_recs WHERE dns_zone_id = $dns_zone_id AND type = 'TXT'");
    my $ZONE  = psasqlcmd_hashref("SELECT * FROM dns_zone WHERE name = '$name'");

    return build_zone( $NS, $A, $CNAME, $MX, $PTR, $TXT, $ZONE );
}

sub build_zone {
    my ( $NS, $A, $CNAME, $MX, $PTR, $TXT, $ZONE ) = @_;
    my $zone_txt;
    my $zone  = $ZONE->[0];
    my $email = $zone->{email};
    $email =~ s/@/./;
    $zone_txt = sprintf <<EOT, $zone->{'ttl_unit'}, $NS->[0]{'val'}, $email, $zone->{'serial'}, $zone->{'refresh'}, $zone->{'retry'}, $zone->{'expire'}, $zone->{'minimum'};
\$TTL\t%s

@\tIN\tSOA\t%s %s (
\t\t\t%d\t; Serial
\t\t\t%s\t; Refresh
\t\t\t%s\t; Retry
\t\t\t%s\t; Expire
\t\t\t%s )\t; Minimum

EOT
    foreach my $ns (@$NS) {
        $zone_txt .= sprintf "%s\t\tIN NS\t%s\n", $ns->{'host'}, $ns->{'val'};
    }
    foreach my $a (@$A) {
        $zone_txt .= sprintf "%s\t\tIN A\t%s\n", $a->{'host'}, $a->{'val'};
    }
    foreach my $cname (@$CNAME) {
        $zone_txt .= sprintf "%s\t\tIN CNAME\t%s\n", $cname->{'host'}, $cname->{'val'};
    }
    foreach my $mx (@$MX) {
        $zone_txt .= sprintf "%s\t\tIN MX\t%s %s\n", $mx->{'host'}, $mx->{'opt'}, $mx->{'val'};
    }
    foreach my $txt (@$TXT) {
        $zone_txt .= sprintf "%s\t\tIN TXT %s\n", $txt->{'host'}, slash_quotes( $txt->{'val'} );
    }
    return $zone_txt;
}

sub psasqlcmd_hashref {
    my ($stmt) = @_;

    my $mysql = find_mysql();

    my $psa1 = get_psa1();
    my $db   = 'psa';
    if ($psa1) {
        $db = 'plesk';
    }

    IPC::Open3::open3( my $mysql_h, my $mysql_res, '', $mysql, $db );

    print {$mysql_h} $stmt;
    close $mysql_h;

    my $data = '';
    while ( my $res = <$mysql_res> ) {
        $data .= $res;
    }

    my @mysql_data = split /\n/, $data;
    my @field_names = map lc, split( /\s+|\t+/, shift(@mysql_data) );
    my @result_set;
    foreach my $row (@mysql_data) {
        my @row = _lexer($row);

        my $results = {};
        my $count   = 0;
        foreach my $field (@field_names) {
            $results->{$field} = $row[$count];
            $count++;
        }

        push @result_set, $results;
    }

    return \@result_set;
}

sub _lexer {
    my ($line) = @_;
    $line =~ s/\s{2,}/ /;
    my $buffer;
    my @stash;
    my $in_double_quote = 0;
    my $in_single_quote = 0;
    foreach my $chr ( split //, $line ) {
        if ( $chr =~ /\"/ ) {
            $in_double_quote = !$in_double_quote;
        }
        if ( $chr =~ /\'/ ) {
            $in_single_quote = !$in_single_quote;
        }
        if ( $chr =~ /\s/ && ( !$in_double_quote && !$in_single_quote ) ) {
            push @stash, $buffer;
            $buffer = '';
        }
        else {
            $buffer .= $chr;
        }
    }
    return @stash, $buffer;
}

sub slash_quotes {
    my ($text) = @_;
    foreach ($text) {
        s/'/\\'/go;
        s/"/\\"/go;
    }
    return qq{"$text"};
}

sub get_ssl {
    my ($dns) = @_;
    my $data = psasqlcmd_hashref(
        "SELECT domains.name, c.pvt_key, c.cert, c.csr
        FROM domains, Repository r, certificates c
        LEFT JOIN IP_Addresses ip ON c.id=ip.ssl_certificate_id
        WHERE r.rep_id=domains.cert_rep_id and r.component_id=c.id AND domains.name = '$dns' GROUP BY c.id"
    );

    foreach my $cert_ref (@$data) {
        $cert_ref->{'pvt_key'} =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;
        $cert_ref->{'cert'}    =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;

        $cert_ref->{'pvt_key'} = _clean_certs( $cert_ref->{'pvt_key'} );
        $cert_ref->{'cert'}    = _clean_certs( $cert_ref->{'cert'} );
    }

    return $data;
}

sub _clean_certs {
    my ($string) = @_;
    my @text = split /\n/, $string;
    my $coverted_string;
    foreach my $line (@text) {
        if ( $line =~ /^-----/ ) {
            $line =~ s/\+/ /g;
        }
        $coverted_string .= $line . "\n";
    }
    return $coverted_string;
}

sub get_account_limits {
    my ($domain) = @_;
    my $translate = {
        disk_space      => 'quota',
        max_db          => 'MAXSQL',
        max_dom_aliases => 'MAXADDON',
        ## see below: MAXADDON and MAXPARK draw from max_dom_aliases
        max_maillists => 'MAXLST',
        max_subdom    => 'MAXSUB',
        max_wu        => 'MAXFTP',
        max_box       => 'MAXPOP',
        mbox_quota    => 'mbox_quota',
    };
    my $data = psasqlcmd_hashref("SELECT Limits.limit_name, Limits.value FROM Limits LEFT JOIN domains ON (domains.limits_id = Limits.id) WHERE domains.name ='$domain'");

    my $stash = {
        MAXSQL   => 'unlimited',
        MAXADDON => 0,
        MAXLST   => 'unlimited',
        MAXSUB   => 'unlimited',
        MAXFTP   => 'unlimited',
        MAXPOP   => 'unlimited',
    };
    foreach my $limits ( @{$data} ) {
        if ( exists $translate->{ $limits->{'limit_name'} } ) {
            $limits->{'value'} ||= 0;
            $limits->{'value'} = ( $limits->{'value'} == -1 ) ? 'unlimited' : $limits->{'value'};
            $stash->{ $translate->{ $limits->{'limit_name'} } } = $limits->{'value'};
            if ( $limits->{'limit_name'} eq 'max_dom_aliases' ) {
                $stash->{'MAXPARK'} = $limits->{'value'};
            }
        }
    }
    return $stash;
}

sub collect_autoresponders {
    my ( $dns, $work_dir ) = @_;

    print "pXa Collecting autoresponders...";
    my $sql = qq(SELECT mail.autoresponder, mail_resp.resp_on, mail.mail_name, domains.name,
  mail_resp.reply_to, mail_resp.content_type, mail_resp.charset, mail_resp.subject, mail_resp.text
FROM (mail JOIN domains ON mail.dom_id = domains.id
      AND domains.name = '$dns')
  JOIN mail_resp ON mail_resp.mn_id = mail.id);

    my $autoresps = psasqlcmd($sql);

    if ( defined $autoresps ) {
        mkdir("$work_dir/homedir/.autorespond");
        my @autoresps = split( /\n/, $autoresps );
        for my $autoresp (@autoresps) {
            my ( $on, $resp_on, $mail_name, $name, $reply_to, $content_type, $charset, $subject, $text ) = split( /\t/, $autoresp );
            next unless ( $on eq 'true' && $resp_on eq 'true' );
            my $fullname = sprintf( "%s@%s", $mail_name, $name );
            open( my $autoresp, '>', "$work_dir/homedir/.autorespond/$fullname" );

            $text =~ s/\\n/\n/g;
            $text =~ s/\\t/\t/g;

            my $msg = qq(From: "$reply_to" <$reply_to>
Content-type: $content_type; charset=$charset
Subject: $subject

$text

);
            print $autoresp $msg;
            close $autoresp;
        }
    }

    print "Done\n";
    return;
}

sub collect_protected_dirs {
    my ( $domainid, $work_dir, $homedir ) = @_;

    ## case 16258
    my $salt = _salt();

    my $sql_protect_dirs = qq(select pd.realm, pd.path,
  pu.login, acc.password as plain,
  ENCRYPT(acc.password, '$salt') AS crypt
from protected_dirs as pd,
  pd_users as pu,
  accounts as acc
where pd.id = pu.pd_id
  and acc.id = pu.account_id
  and dom_id = $domainid
);

    my $protect_dirs = psasqlcmd($sql_protect_dirs);
    my @lines = split( /\n/, $protect_dirs );
    for my $line (@lines) {
        my ( $realm, $subdir, $login, undef, $passwd ) = split( /\t/, $line );
        ## Cpanel does not currently support subdirectories.
        next if ( $subdir =~ m/\// );

        ## Plesk only currently supports directories in public_html
        my $path_htaccess = "$work_dir/homedir/public_html/$subdir/.htaccess";

        ## note: this outputs as $homedir=/var/www/vhosts, but the homedir_paths functionality
        ##   handles this correctly on the destination side
        open( my $htaccess, '>', $path_htaccess );
        print $htaccess qq(AuthType Basic
AuthName "$realm"
AuthUserFile "$homedir/.htpasswds/public_html/$subdir/passwd"
require valid-user\n);

        my $dir_htpass = "$work_dir/homedir/.htpasswds/public_html/$subdir";
        system("mkdir -p $dir_htpass");

        open( my $htpass, '>>', "$dir_htpass/passwd" );
        print $htpass "$login:$passwd\n";
    }

    return;
}

sub clean_mysql_username {
    my ($cpuser) = @_;

    $cpuser = substr $cpuser, 0, 16;
    return $cpuser;
}

sub parks {
    my ( $clientid, $login ) = @_;

    my $sys_users = psasqlcmd("SELECT home FROM sys_users WHERE shell <> ''");

    my @wanted = ();
    foreach my $home ( split /\n/, $sys_users ) {
        $home =~ /([^\/]+)\/?$/;
        my $domain = $1;
        if ( $domain =~ /\.(?:\S+)/ ) {
            push @wanted, $domain;
        }
    }

    my @dom_ids = ();
    foreach my $domain (@wanted) {
        my $id = psasqlcmd("SELECT id FROM domains WHERE name = '$domain';");
        chomp($id);
        push @dom_ids, $id;
    }

    my $ids = join ',', @dom_ids;

    my $parks = psasqlcmd("SELECT domains.name, forwarding.redirect FROM domains LEFT JOIN forwarding ON domains.id = forwarding.dom_id JOIN clients ON clients.id = domains.cl_id WHERE clients.login = '$login' and domains.cl_id = $clientid and domains.id NOT IN ($ids)\n");

    my @lines = split /\n/, $parks;
    my @parks = map { [ split /\s+/ ] } @lines;
    return \@parks;
}

sub url_escape {
    my ($url) = @_;

    $url =~ s{\/$}{};
    for ($url) {
        s{/}{\\/}g;
        s/\./\\\./g;
        s/:/\\:/g;
    }
    return $url;
}

sub write_redirect_htaccess {
    my ( $old_url, $url ) = @_;

    my $escaped_url = url_escape($url);

    my $htaccess = <<EOT;
RewriteCond \%{HTTP_HOST} ^$old_url\$ [OR]
RewriteCond \%{HTTP_HOST} ^www.$old_url\$
RewriteRule ^/?\$ "$escaped_url" [R=301,L]
EOT

    return $htaccess;
}

sub db_exists {
    my $db        = shift;
    my $quoted_db = quote($db);
    my $ms        = psasqlcmd("SHOW DATABASES LIKE $quoted_db;");
    $ms =~ s/\s//g;

    return ( $ms =~ /$db/ ) ? 1 : 0;
}

1;