#!/usr/bin/perl

# cpanel - Whostmgr/Pkgacct/dump_databases_and_users-plesk
#                                                  Copyright 2022 cPanel, L.L.C.
#                                                           All rights reserved.
# copyright@cpanel.net                                         http://cpanel.net
# This code is subject to the cPanel license. Unauthorized copying is prohibited

BEGIN {
    my %seen_inc;
    @INC = grep { !/(?:^\.|\.\.|\/\.+)/ && !$seen_inc{$_}++ } @INC;
    undef %seen_inc;
}

package    # This is JSON::backportPP
  JSON::PP;

# JSON-2.0

use 5.005;
use strict;
use base     qw(Exporter);
use overload ();

use Carp ();
use B    ();

#use Devel::Peek;

use vars qw($VERSION);
$VERSION = '2.27204';

@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);

# instead of hash-access, i tried index-access for speed.
# but this method is not faster than what i expected. so it will be changed.

use constant P_ASCII           => 0;
use constant P_LATIN1          => 1;
use constant P_UTF8            => 2;
use constant P_INDENT          => 3;
use constant P_CANONICAL       => 4;
use constant P_SPACE_BEFORE    => 5;
use constant P_SPACE_AFTER     => 6;
use constant P_ALLOW_NONREF    => 7;
use constant P_SHRINK          => 8;
use constant P_ALLOW_BLESSED   => 9;
use constant P_CONVERT_BLESSED => 10;
use constant P_RELAXED         => 11;

use constant P_LOOSE             => 12;
use constant P_ALLOW_BIGNUM      => 13;
use constant P_ALLOW_BAREKEY     => 14;
use constant P_ALLOW_SINGLEQUOTE => 15;
use constant P_ESCAPE_SLASH      => 16;
use constant P_AS_NONBLESSED     => 17;

use constant P_ALLOW_UNKNOWN => 18;

use constant OLD_PERL => $] < 5.008 ? 1 : 0;

BEGIN {
    my @xs_compati_bit_properties = qw(
      latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
      allow_blessed convert_blessed relaxed allow_unknown
    );
    my @pp_bit_properties = qw(
      allow_singlequote allow_bignum loose
      allow_barekey escape_slash as_nonblessed
    );

    # Perl version check, Unicode handling is enable?
    # Helper module sets @JSON::PP::_properties.
    if ( $] < 5.008 ) {
        my $helper = $] >= 5.006 ? 'JSON::backportPP::Compat5006' : 'JSON::backportPP::Compat5005';
        eval qq| require $helper |;
        if ($@) { Carp::croak $@; }
    }

    for my $name ( @xs_compati_bit_properties, @pp_bit_properties ) {
        my $flag_name = 'P_' . uc($name);

        eval qq/
            sub $name {
                my \$enable = defined \$_[1] ? \$_[1] : 1;

                if (\$enable) {
                    \$_[0]->{PROPS}->[$flag_name] = 1;
                }
                else {
                    \$_[0]->{PROPS}->[$flag_name] = 0;
                }

                \$_[0];
            }

            sub get_$name {
                \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
            }
        /;
    }

}

# Functions

my %encode_allow_method = map { ( $_ => 1 ) } qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
  allow_blessed convert_blessed indent indent_length allow_bignum
  as_nonblessed
  /;
my %decode_allow_method = map { ( $_ => 1 ) } qw/utf8 allow_nonref loose allow_singlequote allow_bignum
  allow_barekey max_size relaxed/;

my $JSON;    # cache

sub encode_json ($) {    # encode
    ( $JSON ||= __PACKAGE__->new->utf8 )->encode(@_);
}

sub decode_json {    # decode
    ( $JSON ||= __PACKAGE__->new->utf8 )->decode(@_);
}

# Obsoleted

sub to_json($) {
    Carp::croak("JSON::PP::to_json has been renamed to encode_json.");
}

sub from_json($) {
    Carp::croak("JSON::PP::from_json has been renamed to decode_json.");
}

# Methods

sub new {
    my $class = shift;
    my $self  = {
        max_depth     => 512,
        max_size      => 0,
        indent        => 0,
        FLAGS         => 0,
        fallback      => sub { encode_error('Invalid value. JSON can only reference.') },
        indent_length => 3,
    };

    return bless $self, $class;
}

sub encode {
    return $_[0]->PP_encode_json( $_[1] );
}

sub decode {
    return $_[0]->PP_decode_json( $_[1], 0x00000000 );
}

sub decode_prefix {
    return $_[0]->PP_decode_json( $_[1], 0x00000001 );
}

# accessor

# pretty printing

sub pretty {
    my ( $self, $v ) = @_;
    my $enable = defined $v ? $v : 1;

    if ($enable) {    # indent_length(3) for JSON::XS compatibility
        $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
    }
    else {
        $self->indent(0)->space_before(0)->space_after(0);
    }

    $self;
}

# etc

sub max_depth {
    my $max = defined $_[1] ? $_[1] : 0x80000000;
    $_[0]->{max_depth} = $max;
    $_[0];
}

sub get_max_depth { $_[0]->{max_depth}; }

sub max_size {
    my $max = defined $_[1] ? $_[1] : 0;
    $_[0]->{max_size} = $max;
    $_[0];
}

sub get_max_size { $_[0]->{max_size}; }

sub filter_json_object {
    $_[0]->{cb_object} = defined $_[1]                                   ? $_[1] : 0;
    $_[0]->{F_HOOK}    = ( $_[0]->{cb_object} or $_[0]->{cb_sk_object} ) ? 1     : 0;
    $_[0];
}

sub filter_json_single_key_object {
    if ( @_ > 1 ) {
        $_[0]->{cb_sk_object}->{ $_[1] } = $_[2];
    }
    $_[0]->{F_HOOK} = ( $_[0]->{cb_object} or $_[0]->{cb_sk_object} ) ? 1 : 0;
    $_[0];
}

sub indent_length {
    if ( !defined $_[1] or $_[1] > 15 or $_[1] < 0 ) {
        Carp::carp "The acceptable range of indent_length() is 0 to 15.";
    }
    else {
        $_[0]->{indent_length} = $_[1];
    }
    $_[0];
}

sub get_indent_length {
    $_[0]->{indent_length};
}

sub sort_by {
    $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
    $_[0];
}

sub allow_bigint {
    Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
}

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

###
### Perl => JSON
###

{    # Convert

    my $max_depth;
    my $indent;
    my $ascii;
    my $latin1;
    my $utf8;
    my $space_before;
    my $space_after;
    my $canonical;
    my $allow_blessed;
    my $convert_blessed;

    my $indent_length;
    my $escape_slash;
    my $bignum;
    my $as_nonblessed;

    my $depth;
    my $indent_count;
    my $keysort;

    sub PP_encode_json {
        my $self = shift;
        my $obj  = shift;

        $indent_count = 0;
        $depth        = 0;

        my $idx = $self->{PROPS};

        (
            $ascii,           $latin1,       $utf8,   $indent, $canonical, $space_before, $space_after, $allow_blessed,
            $convert_blessed, $escape_slash, $bignum, $as_nonblessed
          )
          = @{$idx}[
          P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
          P_ESCAPE_SLASH,           P_ALLOW_BIGNUM,  P_AS_NONBLESSED
          ];

        ( $max_depth, $indent_length ) = @{$self}{qw/max_depth indent_length/};

        $keysort = $canonical ? sub { $a cmp $b } : undef;

        if ( $self->{sort_by} ) {
            $keysort =
                ref( $self->{sort_by} ) eq 'CODE' ? $self->{sort_by}
              : $self->{sort_by} =~ /\D+/         ? $self->{sort_by}
              :                                     sub { $a cmp $b };
        }

        encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
          if ( !ref $obj and !$idx->[P_ALLOW_NONREF] );

        my $str = $self->object_to_json($obj);

        $str .= "\n" if ($indent);    # JSON::XS 2.26 compatible

        unless ( $ascii or $latin1 or $utf8 ) {
            utf8::upgrade($str);
        }

        if ( $idx->[P_SHRINK] ) {
            utf8::downgrade( $str, 1 );
        }

        return $str;
    }

    sub object_to_json {
        my ( $self, $obj ) = @_;
        my $type = ref($obj);

        if ( $type eq 'HASH' ) {
            return $self->hash_to_json($obj);
        }
        elsif ( $type eq 'ARRAY' ) {
            return $self->array_to_json($obj);
        }
        elsif ($type) {    # blessed object?
            if ( blessed($obj) ) {

                return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );

                if ( $convert_blessed and $obj->can('TO_JSON') ) {
                    my $result = $obj->TO_JSON();
                    if ( defined $result and ref($result) ) {
                        if ( refaddr($obj) eq refaddr($result) ) {
                            encode_error(
                                sprintf(
                                    "%s::TO_JSON method returned same object as was passed instead of a new one",
                                    ref $obj
                                )
                            );
                        }
                    }

                    return $self->object_to_json($result);
                }

                return "$obj"                       if ( $bignum        and _is_bignum($obj) );
                return $self->blessed_to_json($obj) if ( $allow_blessed and $as_nonblessed );     # will be removed.

                encode_error( sprintf( "encountered object '%s', but neither allow_blessed " . "nor convert_blessed settings are enabled", $obj ) ) unless ($allow_blessed);

                return 'null';
            }
            else {
                return $self->value_to_json($obj);
            }
        }
        else {
            return $self->value_to_json($obj);
        }
    }

    sub hash_to_json {
        my ( $self, $obj ) = @_;
        my @res;

        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
          if ( ++$depth > $max_depth );

        my ( $pre, $post ) = $indent ? $self->_up_indent() : ( '', '' );
        my $del = ( $space_before ? ' ' : '' ) . ':' . ( $space_after ? ' ' : '' );

        for my $k ( _sort($obj) ) {
            if (OLD_PERL) { utf8::decode($k) }    # key for Perl 5.6 / be optimized
            push @res, string_to_json( $self, $k ) . $del . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
        }

        --$depth;
        $self->_down_indent() if ($indent);

        return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}';
    }

    sub array_to_json {
        my ( $self, $obj ) = @_;
        my @res;

        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
          if ( ++$depth > $max_depth );

        my ( $pre, $post ) = $indent ? $self->_up_indent() : ( '', '' );

        for my $v (@$obj) {
            push @res, $self->object_to_json($v) || $self->value_to_json($v);
        }

        --$depth;
        $self->_down_indent() if ($indent);

        return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
    }

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

        return 'null' if ( !defined $value );

        my $b_obj = B::svref_2object( \$value );    # for round trip problem
        my $flags = $b_obj->FLAGS;

        return $value                                                              # as is
          if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK );    # SvTYPE is IV or NV?

        my $type = ref($value);

        if ( !$type ) {
            return string_to_json( $self, $value );
        }
        elsif ( blessed($value) and $value->isa('JSON::PP::Boolean') ) {
            return $$value == 1 ? 'true' : 'false';
        }
        elsif ($type) {
            if ( ( overload::StrVal($value) =~ /=(\w+)/ )[0] ) {
                return $self->value_to_json("$value");
            }

            if ( $type eq 'SCALAR' and defined $$value ) {
                return
                    $$value eq '1'                    ? 'true'
                  : $$value eq '0'                    ? 'false'
                  : $self->{PROPS}->[P_ALLOW_UNKNOWN] ? 'null'
                  :                                     encode_error("cannot encode reference to scalar");
            }

            if ( $self->{PROPS}->[P_ALLOW_UNKNOWN] ) {
                return 'null';
            }
            else {
                if ( $type eq 'SCALAR' or $type eq 'REF' ) {
                    encode_error("cannot encode reference to scalar");
                }
                else {
                    encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
                }
            }

        }
        else {
            return $self->{fallback}->($value)
              if ( $self->{fallback} and ref( $self->{fallback} ) eq 'CODE' );
            return 'null';
        }

    }

    my %esc = (
        "\n" => '\n',
        "\r" => '\r',
        "\t" => '\t',
        "\f" => '\f',
        "\b" => '\b',
        "\"" => '\"',
        "\\" => '\\\\',
        "\'" => '\\\'',
    );

    sub string_to_json {
        my ( $self, $arg ) = @_;

        $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
        $arg =~ s/\//\\\//g if ($escape_slash);
        $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;

        if ($ascii) {
            $arg = JSON_PP_encode_ascii($arg);
        }

        if ($latin1) {
            $arg = JSON_PP_encode_latin1($arg);
        }

        if ($utf8) {
            utf8::encode($arg);
        }

        return '"' . $arg . '"';
    }

    sub blessed_to_json {
        my $reftype = reftype( $_[1] ) || '';
        if ( $reftype eq 'HASH' ) {
            return $_[0]->hash_to_json( $_[1] );
        }
        elsif ( $reftype eq 'ARRAY' ) {
            return $_[0]->array_to_json( $_[1] );
        }
        else {
            return 'null';
        }
    }

    sub encode_error {
        my $error = shift;
        Carp::croak "$error";
    }

    sub _sort {
        defined $keysort ? ( sort $keysort ( keys %{ $_[0] } ) ) : keys %{ $_[0] };
    }

    sub _up_indent {
        my $self  = shift;
        my $space = ' ' x $indent_length;

        my ( $pre, $post ) = ( '', '' );

        $post = "\n" . $space x $indent_count;

        $indent_count++;

        $pre = "\n" . $space x $indent_count;

        return ( $pre, $post );
    }

    sub _down_indent { $indent_count--; }

    sub PP_encode_box {
        {
            depth        => $depth,
            indent_count => $indent_count,
        };
    }

}    # Convert

sub _encode_ascii {
    join(
        '',
        map { $_ <= 127 ? chr($_) : $_ <= 65535 ? sprintf( '\u%04x', $_ ) : sprintf( '\u%x\u%x', _encode_surrogates($_) ); } unpack( 'U*', $_[0] )
    );
}

sub _encode_latin1 {
    join(
        '',
        map { $_ <= 255 ? chr($_) : $_ <= 65535 ? sprintf( '\u%04x', $_ ) : sprintf( '\u%x\u%x', _encode_surrogates($_) ); } unpack( 'U*', $_[0] )
    );
}

sub _encode_surrogates {    # from perlunicode
    my $uni = $_[0] - 0x10000;
    return ( $uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00 );
}

sub _is_bignum {
    $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
}

#
# JSON => Perl
#

my $max_intsize;

BEGIN {
    my $checkint = 1111;
    for my $d ( 5 .. 64 ) {
        $checkint .= 1;
        my $int = eval qq| $checkint |;
        if ( $int =~ /[eE]/ ) {
            $max_intsize = $d - 1;
            last;
        }
    }
}

{    # PARSE

    my %escapes = (    #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
        b    => "\x8",
        t    => "\x9",
        n    => "\xA",
        f    => "\xC",
        r    => "\xD",
        '\\' => '\\',
        '"'  => '"',
        '/'  => '/',
    );

    my $text;             # json data
    my $at;               # offset
    my $ch;               # 1chracter
    my $len;              # text length (changed according to UTF8 or NON UTF8)
                          # INTERNAL
    my $depth;            # nest counter
    my $encoding;         # json text encoding
    my $is_valid_utf8;    # temp variable
    my $utf8_len;         # utf8 byte length
                          # FLAGS
    my $utf8;             # must be utf8
    my $max_depth;        # max nest number of objects and arrays
    my $max_size;
    my $relaxed;
    my $cb_object;
    my $cb_sk_object;

    my $F_HOOK;

    my $allow_bigint;     # using Math::BigInt
    my $singlequote;      # loosely quoting
    my $loose;            #
    my $allow_barekey;    # bareKey

    # $opt flag
    # 0x00000001 .... decode_prefix
    # 0x10000000 .... incr_parse

    sub PP_decode_json {
        my ( $self, $opt );    # $opt is an effective flag during this decode_json.

        ( $self, $text, $opt ) = @_;

        ( $at, $ch, $depth ) = ( 0, '', 0 );

        if ( !defined $text or ref $text ) {
            decode_error("malformed JSON string, neither array, object, number, string or atom");
        }

        my $idx = $self->{PROPS};

        ( $utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote ) =
          @{$idx}[ P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE ];

        if ($utf8) {
            utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
        }
        else {
            utf8::upgrade($text);
        }

        $len = length $text;

        ( $max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK ) =
          @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};

        if ( $max_size > 1 ) {
            use bytes;
            my $bytes = length $text;
            decode_error( sprintf( "attempted decode of JSON text of %s bytes size, but max_size is set to %s", $bytes, $max_size ), 1 ) if ( $bytes > $max_size );
        }

        # Currently no effect
        # should use regexp
        my @octets = unpack( 'C4', $text );
        $encoding =
            ( $octets[0] and $octets[1] )   ? 'UTF-8'
          : ( !$octets[0] and $octets[1] )  ? 'UTF-16BE'
          : ( !$octets[0] and !$octets[1] ) ? 'UTF-32BE'
          : ( $octets[2] )                  ? 'UTF-16LE'
          : ( !$octets[2] )                 ? 'UTF-32LE'
          :                                   'unknown';

        white();    # remove head white space

        my $valid_start = defined $ch;    # Is there a first character for JSON structure?

        my $result = value();

        return undef if ( !$result && ( $opt & 0x10000000 ) );    # for incr_parse

        decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;

        if ( !$idx->[P_ALLOW_NONREF] and !ref $result ) {
            decode_error( 'JSON text must be an object or array (but found number, string, true, false or null,' . ' use allow_nonref to allow this)', 1 );
        }

        Carp::croak('something wrong.') if $len < $at;            # we won't arrive here.

        my $consumed = defined $ch ? $at - 1 : $at;               # consumed JSON text length

        white();                                                  # remove tail white space

        if ($ch) {
            return ( $result, $consumed ) if ( $opt & 0x00000001 );    # all right if decode_prefix
            decode_error("garbage after JSON object");
        }

        ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
    }

    sub next_chr {
        return $ch = undef if ( $at >= $len );
        $ch = substr( $text, $at++, 1 );
    }

    sub value {
        white();
        return          if ( !defined $ch );
        return object() if ( $ch eq '{' );
        return array()  if ( $ch eq '[' );
        return string() if ( $ch eq '"'     or ( $singlequote and $ch eq "'" ) );
        return number() if ( $ch =~ /[0-9]/ or $ch eq '-' );
        return word();
    }

    sub string {
        my $s;
        my $utf16;
        my $is_utf8;

        ( $is_valid_utf8, $utf8_len ) = ( '', 0 );

        $s = '';    # basically UTF8 flag on

        if ( $ch eq '"' or ( $singlequote and $ch eq "'" ) ) {
            my $boundChar = $ch;

          OUTER: while ( defined( next_chr() ) ) {

                if ( $ch eq $boundChar ) {
                    next_chr();

                    if ($utf16) {
                        decode_error("missing low surrogate character in surrogate pair");
                    }

                    utf8::decode($s) if ($is_utf8);

                    return $s;
                }
                elsif ( $ch eq '\\' ) {
                    next_chr();
                    if ( exists $escapes{$ch} ) {
                        $s .= $escapes{$ch};
                    }
                    elsif ( $ch eq 'u' ) {    # UNICODE handling
                        my $u = '';

                        for ( 1 .. 4 ) {
                            $ch = next_chr();
                            last OUTER if ( $ch !~ /[0-9a-fA-F]/ );
                            $u .= $ch;
                        }

                        # U+D800 - U+DBFF
                        if ( $u =~ /^[dD][89abAB][0-9a-fA-F]{2}/ ) {    # UTF-16 high surrogate?
                            $utf16 = $u;
                        }

                        # U+DC00 - U+DFFF
                        elsif ( $u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/ ) {    # UTF-16 low surrogate?
                            unless ( defined $utf16 ) {
                                decode_error("missing high surrogate character in surrogate pair");
                            }
                            $is_utf8 = 1;
                            $s .= JSON_PP_decode_surrogates( $utf16, $u ) || next;
                            $utf16 = undef;
                        }
                        else {
                            if ( defined $utf16 ) {
                                decode_error("surrogate pair expected");
                            }

                            if ( ( my $hex = hex($u) ) > 127 ) {
                                $is_utf8 = 1;
                                $s .= JSON_PP_decode_unicode($u) || next;
                            }
                            else {
                                $s .= chr $hex;
                            }
                        }

                    }
                    else {
                        unless ($loose) {
                            $at -= 2;
                            decode_error('illegal backslash escape sequence in string');
                        }
                        $s .= $ch;
                    }
                }
                else {

                    if ( ord $ch > 127 ) {
                        if ($utf8) {
                            unless ( $ch = is_valid_utf8($ch) ) {
                                $at -= 1;
                                decode_error("malformed UTF-8 character in JSON string");
                            }
                            else {
                                $at += $utf8_len - 1;
                            }
                        }
                        else {
                            utf8::encode($ch);
                        }

                        $is_utf8 = 1;
                    }

                    if ( !$loose ) {
                        if ( $ch =~ /[\x00-\x1f\x22\x5c]/ ) {    # '/' ok
                            $at--;
                            decode_error('invalid character encountered while parsing JSON string');
                        }
                    }

                    $s .= $ch;
                }
            }
        }

        decode_error("unexpected end of string while parsing JSON string");
    }

    sub white {
        while ( defined $ch ) {
            if ( $ch le ' ' ) {
                next_chr();
            }
            elsif ( $ch eq '/' ) {
                next_chr();
                if ( defined $ch and $ch eq '/' ) {
                    1 while ( defined( next_chr() ) and $ch ne "\n" and $ch ne "\r" );
                }
                elsif ( defined $ch and $ch eq '*' ) {
                    next_chr();
                    while (1) {
                        if ( defined $ch ) {
                            if ( $ch eq '*' ) {
                                if ( defined( next_chr() ) and $ch eq '/' ) {
                                    next_chr();
                                    last;
                                }
                            }
                            else {
                                next_chr();
                            }
                        }
                        else {
                            decode_error("Unterminated comment");
                        }
                    }
                    next;
                }
                else {
                    $at--;
                    decode_error("malformed JSON string, neither array, object, number, string or atom");
                }
            }
            else {
                if ( $relaxed and $ch eq '#' ) {    # correctly?
                    pos($text) = $at;
                    $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
                    $at = pos($text);
                    next_chr;
                    next;
                }

                last;
            }
        }
    }

    sub array {
        my $a = $_[0] || [];    # you can use this code to use another array ref object.

        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
          if ( ++$depth > $max_depth );

        next_chr();
        white();

        if ( defined $ch and $ch eq ']' ) {
            --$depth;
            next_chr();
            return $a;
        }
        else {
            while ( defined($ch) ) {
                push @$a, value();

                white();

                if ( !defined $ch ) {
                    last;
                }

                if ( $ch eq ']' ) {
                    --$depth;
                    next_chr();
                    return $a;
                }

                if ( $ch ne ',' ) {
                    last;
                }

                next_chr();
                white();

                if ( $relaxed and $ch eq ']' ) {
                    --$depth;
                    next_chr();
                    return $a;
                }

            }
        }

        decode_error(", or ] expected while parsing array");
    }

    sub object {
        my $o = $_[0] || {};    # you can use this code to use another hash ref object.
        my $k;

        decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
          if ( ++$depth > $max_depth );
        next_chr();
        white();

        if ( defined $ch and $ch eq '}' ) {
            --$depth;
            next_chr();
            if ($F_HOOK) {
                return _json_object_hook($o);
            }
            return $o;
        }
        else {
            while ( defined $ch ) {
                $k = ( $allow_barekey and $ch ne '"' and $ch ne "'" ) ? bareKey() : string();
                white();

                if ( !defined $ch or $ch ne ':' ) {
                    $at--;
                    decode_error("':' expected");
                }

                next_chr();
                $o->{$k} = value();
                white();

                last if ( !defined $ch );

                if ( $ch eq '}' ) {
                    --$depth;
                    next_chr();
                    if ($F_HOOK) {
                        return _json_object_hook($o);
                    }
                    return $o;
                }

                if ( $ch ne ',' ) {
                    last;
                }

                next_chr();
                white();

                if ( $relaxed and $ch eq '}' ) {
                    --$depth;
                    next_chr();
                    if ($F_HOOK) {
                        return _json_object_hook($o);
                    }
                    return $o;
                }

            }

        }

        $at--;
        decode_error(", or } expected while parsing object/hash");
    }

    sub bareKey {    # doesn't strictly follow Standard ECMA-262 3rd Edition
        my $key;
        while ( $ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/ ) {
            $key .= $ch;
            next_chr();
        }
        return $key;
    }

    sub word {
        my $word = substr( $text, $at - 1, 4 );

        if ( $word eq 'true' ) {
            $at += 3;
            next_chr;
            return $JSON::PP::true;
        }
        elsif ( $word eq 'null' ) {
            $at += 3;
            next_chr;
            return undef;
        }
        elsif ( $word eq 'fals' ) {
            $at += 3;
            if ( substr( $text, $at, 1 ) eq 'e' ) {
                $at++;
                next_chr;
                return $JSON::PP::false;
            }
        }

        $at--;    # for decode_error report

        decode_error("'null' expected")  if ( $word =~ /^n/ );
        decode_error("'true' expected")  if ( $word =~ /^t/ );
        decode_error("'false' expected") if ( $word =~ /^f/ );
        decode_error("malformed JSON string, neither array, object, number, string or atom");
    }

    sub number {
        my $n = '';
        my $v;

        # According to RFC4627, hex or oct digits are invalid.
        if ( $ch eq '0' ) {
            my $peek = substr( $text, $at, 1 );
            my $hex  = $peek =~ /[xX]/;           # 0 or 1

            if ($hex) {
                decode_error("malformed number (leading zero must not be followed by another digit)");
                ($n) = ( substr( $text, $at + 1 ) =~ /^([0-9a-fA-F]+)/ );
            }
            else {                                # oct
                ($n) = ( substr( $text, $at ) =~ /^([0-7]+)/ );
                if ( defined $n and length $n > 1 ) {
                    decode_error("malformed number (leading zero must not be followed by another digit)");
                }
            }

            if ( defined $n and length($n) ) {
                if ( !$hex and length($n) == 1 ) {
                    decode_error("malformed number (leading zero must not be followed by another digit)");
                }
                $at += length($n) + $hex;
                next_chr;
                return $hex ? hex($n) : oct($n);
            }
        }

        if ( $ch eq '-' ) {
            $n = '-';
            next_chr;
            if ( !defined $ch or $ch !~ /\d/ ) {
                decode_error("malformed number (no digits after initial minus)");
            }
        }

        while ( defined $ch and $ch =~ /\d/ ) {
            $n .= $ch;
            next_chr;
        }

        if ( defined $ch and $ch eq '.' ) {
            $n .= '.';

            next_chr;
            if ( !defined $ch or $ch !~ /\d/ ) {
                decode_error("malformed number (no digits after decimal point)");
            }
            else {
                $n .= $ch;
            }

            while ( defined(next_chr) and $ch =~ /\d/ ) {
                $n .= $ch;
            }
        }

        if ( defined $ch and ( $ch eq 'e' or $ch eq 'E' ) ) {
            $n .= $ch;
            next_chr;

            if ( defined($ch) and ( $ch eq '+' or $ch eq '-' ) ) {
                $n .= $ch;
                next_chr;
                if ( !defined $ch or $ch =~ /\D/ ) {
                    decode_error("malformed number (no digits after exp sign)");
                }
                $n .= $ch;
            }
            elsif ( defined($ch) and $ch =~ /\d/ ) {
                $n .= $ch;
            }
            else {
                decode_error("malformed number (no digits after exp sign)");
            }

            while ( defined(next_chr) and $ch =~ /\d/ ) {
                $n .= $ch;
            }

        }

        $v .= $n;

        if ( $v !~ /[.eE]/ and length $v > $max_intsize ) {
            if ($allow_bigint) {    # from Adam Sussman
                require Math::BigInt;
                return Math::BigInt->new($v);
            }
            else {
                return "$v";
            }
        }
        elsif ($allow_bigint) {
            require Math::BigFloat;
            return Math::BigFloat->new($v);
        }

        return 0 + $v;
    }

    sub is_valid_utf8 {

        $utf8_len =
            $_[0] =~ /[\x00-\x7F]/ ? 1
          : $_[0] =~ /[\xC2-\xDF]/ ? 2
          : $_[0] =~ /[\xE0-\xEF]/ ? 3
          : $_[0] =~ /[\xF0-\xF4]/ ? 4
          :                          0;

        return unless $utf8_len;

        my $is_valid_utf8 = substr( $text, $at - 1, $utf8_len );

        return (
            $is_valid_utf8 =~ /^(?:
             [\x00-\x7F]
            |[\xC2-\xDF][\x80-\xBF]
            |[\xE0][\xA0-\xBF][\x80-\xBF]
            |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
            |[\xED][\x80-\x9F][\x80-\xBF]
            |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
            |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
            |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
            |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
        )$/x
        ) ? $is_valid_utf8 : '';
    }

    sub decode_error {
        my $error  = shift;
        my $no_rep = shift;
        my $str    = defined $text ? substr( $text, $at ) : '';
        my $mess   = '';
        my $type =
            $] >= 5.008         ? 'U*'
          : $] < 5.006          ? 'C*'
          : utf8::is_utf8($str) ? 'U*'    # 5.6
          :                       'C*';

        for my $c ( unpack( $type, $str ) ) {    # emulate pv_uni_display() ?
            $mess .=
                $c == 0x07 ? '\a'
              : $c == 0x09 ? '\t'
              : $c == 0x0a ? '\n'
              : $c == 0x0d ? '\r'
              : $c == 0x0c ? '\f'
              : $c < 0x20  ? sprintf( '\x{%x}', $c )
              : $c == 0x5c ? '\\\\'
              : $c < 0x80  ? chr($c)
              :              sprintf( '\x{%x}', $c );
            if ( length $mess >= 20 ) {
                $mess .= '...';
                last;
            }
        }

        unless ( length $mess ) {
            $mess = '(end of string)';
        }

        Carp::croak( $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" );

    }

    sub _json_object_hook {
        my $o  = $_[0];
        my @ks = keys %{$o};

        if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
            my @val = $cb_sk_object->{ $ks[0] }->( $o->{ $ks[0] } );
            if ( @val == 1 ) {
                return $val[0];
            }
        }

        my @val = $cb_object->($o) if ($cb_object);
        if ( @val == 0 or @val > 1 ) {
            return $o;
        }
        else {
            return $val[0];
        }
    }

    sub PP_decode_box {
        {
            text          => $text,
            at            => $at,
            ch            => $ch,
            len           => $len,
            depth         => $depth,
            encoding      => $encoding,
            is_valid_utf8 => $is_valid_utf8,
        };
    }

}    # PARSE

sub _decode_surrogates {    # from perlunicode
    my $uni = 0x10000 + ( hex( $_[0] ) - 0xD800 ) * 0x400 + ( hex( $_[1] ) - 0xDC00 );
    my $un  = pack( 'U*', $uni );
    utf8::encode($un);
    return $un;
}

sub _decode_unicode {
    my $un = pack( 'U', hex shift );
    utf8::encode($un);
    return $un;
}

#
# Setup for various Perl versions (the code from JSON::PP58)
#

BEGIN {

    unless ( defined &utf8::is_utf8 ) {
        no warnings 'once';
        require Encode;
        *utf8::is_utf8 = *Encode::is_utf8;
    }

    if ( $] >= 5.008 ) {
        *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
        *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
        *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
        *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
    }

    if ( $] >= 5.008 and $] < 5.008003 ) {    # join() in 5.8.0 - 5.8.2 is broken.
        package                               # hide from PAUSE
          JSON::PP;
        require subs;
        subs->import('join');
        eval q|
            sub join {
                return '' if (@_ < 2);
                my $j   = shift;
                my $str = shift;
                for (@_) { $str .= $j . $_; }
                return $str;
            }
        |;
    }

    sub JSON::PP::incr_parse {
        local $Carp::CarpLevel = 1;
        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse(@_);
    }

    sub JSON::PP::incr_skip {
        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
    }

    sub JSON::PP::incr_reset {
        ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
    }

    eval q{
        sub JSON::PP::incr_text : lvalue {
            $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;

            if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
                Carp::croak("incr_text can not be called when the incremental parser already started parsing");
            }
            $_[0]->{_incr_parser}->{incr_text};
        }
    } if ( $] >= 5.006 );

}    # Setup for various Perl versions (the code from JSON::PP58)

###############################
# Utilities
#

BEGIN {
    eval 'require Scalar::Util';
    unless ($@) {
        *JSON::PP::blessed = \&Scalar::Util::blessed;
        *JSON::PP::reftype = \&Scalar::Util::reftype;
        *JSON::PP::refaddr = \&Scalar::Util::refaddr;
    }
    else {    # This code is from Scalar::Util.
              # warn $@;
        eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
        *JSON::PP::blessed = sub {
            local ( $@, $SIG{__DIE__}, $SIG{__WARN__} );
            ref( $_[0] ) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
        };
        my %tmap = qw(
          B::NULL   SCALAR
          B::HV     HASH
          B::AV     ARRAY
          B::CV     CODE
          B::IO     IO
          B::GV     GLOB
          B::REGEXP REGEXP
        );
        *JSON::PP::reftype = sub {
            my $r = shift;

            return undef unless length( ref($r) );

            my $t = ref( B::svref_2object($r) );

            return
                exists $tmap{$t}   ? $tmap{$t}
              : length( ref($$r) ) ? 'REF'
              :                      'SCALAR';
        };
        *JSON::PP::refaddr = sub {
            return undef unless length( ref( $_[0] ) );

            my $addr;
            if ( defined( my $pkg = blessed( $_[0] ) ) ) {
                $addr .= bless $_[0], 'Scalar::Util::Fake';
                bless $_[0], $pkg;
            }
            else {
                $addr .= $_[0];
            }

            $addr =~ /0x(\w+)/;
            local $^W;

            #no warnings 'portable';
            hex($1);
        }
    }
}

# shamelessly copied and modified from JSON::XS code.

unless ( $INC{'JSON/PP.pm'} ) {
    eval q|
        package
            JSON::PP::Boolean;

        use overload (
            "0+"     => sub { ${$_[0]} },
            "++"     => sub { $_[0] = ${$_[0]} + 1 },
            "--"     => sub { $_[0] = ${$_[0]} - 1 },
            fallback => 1,
        );
    |;
}

$JSON::PP::true  = do { bless \( my $dummy = 1 ), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \( my $dummy = 0 ), "JSON::PP::Boolean" };

sub is_bool { defined $_[0] and UNIVERSAL::isa( $_[0], "JSON::PP::Boolean" ); }

sub true  { $JSON::PP::true }
sub false { $JSON::PP::false }
sub null  { undef; }

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

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

package    # hide from PAUSE
  JSON::PP::IncrParser;

use strict;

use constant INCR_M_WS   => 0;    # initial whitespace skipping
use constant INCR_M_STR  => 1;    # inside string
use constant INCR_M_BS   => 2;    # inside backslash
use constant INCR_M_JSON => 3;    # outside anything, count nesting
use constant INCR_M_C0   => 4;
use constant INCR_M_C1   => 5;

use vars qw($VERSION);
$VERSION = '1.01';

my $unpack_format = $] < 5.006 ? 'C*' : 'U*';

sub new {
    my ($class) = @_;

    return bless {
        incr_nest    => 0,
        incr_text    => undef,
        incr_parsing => 0,
        incr_p       => 0,
    }, $class;
}

sub incr_parse {
    my ( $self, $coder, $text ) = @_;

    $self->{incr_text} = '' unless ( defined $self->{incr_text} );

    if ( defined $text ) {
        if ( utf8::is_utf8($text) and !utf8::is_utf8( $self->{incr_text} ) ) {
            utf8::upgrade( $self->{incr_text} );
            utf8::decode( $self->{incr_text} );
        }
        $self->{incr_text} .= $text;
    }

    my $max_size = $coder->get_max_size;

    if ( defined wantarray ) {

        $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};

        if (wantarray) {
            my @ret;

            $self->{incr_parsing} = 1;

            do {
                push @ret, $self->_incr_parse( $coder, $self->{incr_text} );

                unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
                    $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
                }

            } until ( length $self->{incr_text} >= $self->{incr_p} );

            $self->{incr_parsing} = 0;

            return @ret;
        }
        else {    # in scalar context
            $self->{incr_parsing} = 1;
            my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
            $self->{incr_parsing} = 0 if defined $obj;    # pointed by Martin J. Evans
            return $obj ? $obj : undef;                   # $obj is an empty string, parsing was completed.
        }

    }

}

sub _incr_parse {
    my ( $self, $coder, $text ) = @_;
    my $p       = $self->{incr_p};
    my $restore = $p;

    my $len = length $text;

    if ( $self->{incr_mode} == INCR_M_WS ) {
        while ( $len > $p ) {
            my $s = substr( $text, $p, 1 );
            $p++ and next if ( 0x20 >= unpack( $unpack_format, $s ) );
            $self->{incr_mode} = INCR_M_JSON;
            last;
        }
    }

    while ( $len > $p ) {
        my $s = substr( $text, $p++, 1 );

        if ( $s eq '"' ) {
            if ( substr( $text, $p - 2, 1 ) eq '\\' ) {
                next;
            }

            if ( $self->{incr_mode} != INCR_M_STR ) {
                $self->{incr_mode} = INCR_M_STR;
            }
            else {
                $self->{incr_mode} = INCR_M_JSON;
                unless ( $self->{incr_nest} ) {
                    last;
                }
            }
        }

        if ( $self->{incr_mode} == INCR_M_JSON ) {

            if ( $s eq '[' or $s eq '{' ) {
                if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
                    Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
                }
            }
            elsif ( $s eq ']' or $s eq '}' ) {
                last if ( --$self->{incr_nest} <= 0 );
            }
            elsif ( $s eq '#' ) {
                while ( $len > $p ) {
                    last if substr( $text, $p++, 1 ) eq "\n";
                }
            }

        }

    }

    $self->{incr_p} = $p;

    return if ( $self->{incr_mode} == INCR_M_STR  and not $self->{incr_nest} );
    return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );

    return '' unless ( length substr( $self->{incr_text}, 0, $p ) );

    local $Carp::CarpLevel = 2;

    $self->{incr_p} = $restore;
    $self->{incr_c} = $p;

    my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );

    $self->{incr_text} = substr( $self->{incr_text}, $p );
    $self->{incr_p}    = 0;

    return $obj || '';
}

sub incr_text {
    if ( $_[0]->{incr_parsing} ) {
        Carp::croak("incr_text can not be called when the incremental parser already started parsing");
    }
    $_[0]->{incr_text};
}

sub incr_skip {
    my $self = shift;
    $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
    $self->{incr_p}    = 0;
}

sub incr_reset {
    my $self = shift;
    $self->{incr_text}    = undef;
    $self->{incr_p}       = 0;
    $self->{incr_mode}    = 0;
    $self->{incr_nest}    = 0;
    $self->{incr_parsing} = 0;
}

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

1;

package Plesk::DatabaseDumper;

use strict;
use warnings;
use IPC::Open3 ();

sub new {
    my ($class) = @_;

    my $self = {};

    bless $self, $class;

    $self->{'psa1'}       = $self->get_psa1();
    $self->{'psaversion'} = $self->getpsaversion();
    $self->{'adminpass'}  = $self->_get_adminpass();

    $self->check_and_recover_mycnf();

    $self->{'is_smb10'}             = $self->check_if_is_smb10();
    $self->{'domains_and_users'}    = $self->get_plesk_domains_and_users();
    $self->{'domain_ids_and_names'} = $self->get_domain_ids_and_names();

    return $self;
}

sub dump_users_and_dbs {
    my ($self) = @_;

    my $master_map = {};

    while ( my ( $dns, $user ) = each( %{ $self->{'domains_and_users'} } ) ) {
        my $sysuserid = $self->psasqlcmd("select id from sys_users where login='$user';");
        next if !$sysuserid;

        my $domainid  = $self->domainid( $dns, $sysuserid, $user );
        my $databases = $self->get_databases($domainid);

        my $sql = qq(
                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 = "mysql"
                    and domains.id = $domainid
            );

        my $dbusers = $self->psasqlcmd($sql);
        next if !$dbusers;
        chomp $dbusers;
        $dbusers =~ s/[\r\n]/ /;

        my @mysql_databases;

        if ( $self->{'psa1'} ) {
            push @mysql_databases, { 'name' => $user };
        }
        else {
            @mysql_databases = grep { $_->{'type'} eq 'mysql' } @{$databases};
        }

        next if !@mysql_databases;

        my @mydbs;
        for my $db (@mysql_databases) {
            push @mydbs, $db->{'name'};
        }
        my @myusers = split /\s/, $dbusers;

        @{ $master_map->{'users'}{'MYSQL'} }{@myusers} = ( ( { 'owner' => $user } ) x scalar @myusers );
        @{ $master_map->{'dbs'}{'MYSQL'} }{@mydbs}     = ( ( { 'owner' => $user } ) x scalar @mydbs );

        delete $master_map->{'users'}{'MYSQL'}{''};
        delete $master_map->{'dbs'}{'MYSQL'}{''};

    }

    return $master_map;
}

sub psasqlcmd {
    my ( $self, $query ) = @_;
    my $result;
    my $handle = $self->get_psasqlcmd_handle(
        $query,
        'no_column_names' => 1
    );
    while ( read( $handle->{'out'}, my $buf, 4096 ) ) {
        $result .= $buf;
    }
    close $handle->{'out'};
    waitpid( $handle->{'pid'}, 0 );
    return ($result);
}

sub get_psasqlcmd_handle {
    my ( $self, $query, %opts ) = @_;

    my $command = $self->find_mysql();
    my @args    = ( $self->{'psa1'} ? 'plesk' : 'psa' );

    unshift @args, '-N' if $opts{'no_column_names'};

    my $err = Symbol::gensym();
    my $pid = IPC::Open3::open3( my ( $in, $out ), $err, $command, @args ) or die("Unable to run $command: $!");

    print {$in} "$query\n";
    close $in;

    #
    # Check to see if any error messages are pending on standard error.  If so,
    # collect them and terminate.
    #
    my $ready = '';
    my $check = '';

    vec( $check, fileno($out), 1 ) = 1;
    vec( $check, fileno($err), 1 ) = 1;
    if ( select( $ready = $check, undef, undef, undef ) && vec( $ready, fileno($err), 1 ) == 1 ) {
        my $message;

        while ( read( $err, my $buf, 4096 ) ) {
            $message .= $buf;
        }

        if ($message) {
            chomp $message;
            die("MySQL error: $message");
        }
    }

    close $err;

    return {
        'pid' => $pid,
        'out' => $out
    };
}

sub check_and_recover_mycnf {
    my ($self) = @_;

    unless ( -e '/root/.my.cnf' ) {
        die "Plesk admin password could not be found, and /root/my.cnf does not exist.  We cannot possibly continue." unless $self->{adminpass};
        open my $mycnf_fh, '>', '/root/.my.cnf' or die "$!";
        print $mycnf_fh "[client]\nuser=admin\npassword=\"" . $self->{adminpass} . "\"\n";
        close $mycnf_fh;
        chmod 0600, '/root/.my.cnf';
    }

    return 1;
}

sub get_psa1 {
    my ($self) = @_;

    return -e "/etc/psa/.psa.shadow" ? 0 : 1;
}

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 domainid {
    my ( $self, $dns, $sysuserid, $user ) = @_;

    if ( $self->{'psaversion'}->{'major'} >= 7 ) {
        return $self->psasqlcmd("select id from domains where name='$dns';");
    }
    elsif ( $self->{'psaversion'}->{'major'} == 6 ) {
        return $self->psasqlcmd("select dom_id from hosting where sys_user_id='$sysuserid';");
    }
    elsif ( $self->{'psaversion'}->{'major'} == 5 ) {
        return $self->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 $self->psasqlcmd("select dom_id from hosting where login='$user';");
    }
}

sub get_domain_ids_and_names {
    my ($self) = @_;
    my $sql = qq( select id,name from domains order by id );

    my %domain_ids_and_names;
    my $output = $self->psasqlcmd($sql);
    foreach ( split( m{\n}, $output ) ) {
        if (m{ \A (\d+) \s+ (\S+) }xms) {
            $domain_ids_and_names{$1} = $2;
        }
    }

    return \%domain_ids_and_names;
}

sub getpsaversion {
    my ($self) = @_;
    my $psadir = getpsadir();
    my %version;

    ## pek NOTE: see /tmp/.../version
    open( PSAV, "${psadir}/version" );
    while (<PSAV>) {

        # We leave the version details undefined if we don't match a unsupported version
        if (/^ ([5-9]|1[0-1]) \.(\d+) \.(\d+) /x) {
            $version{'major'}   = $1;
            $version{'minor'}   = $2;
            $version{'release'} = $3;
        }

        #17.0.17 CentOS 7 1700170322.17
        if ( !$version{major} ) {
            ( $version{major}, $version{minor}, $version{release} ) = $_ =~ m/^(\d*)\.(\d*)\.(\d*)/x;
        }
    }
    close(PSAV);

    return \%version;
}

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

sub get_plesk_domains_and_users {
    my ($self) = @_;
    my $sql;

    my %plesk_domains_and_users;
    if ( defined $self->{'is_smb10'} || $self->{'psaversion'}->{'major'} < 10 ) {
        $sql = qq(
                select
                    su.login as name,
                    d.name as domain,
                    d.id as domain_id,
                    d.cl_id as client_id
                from
                    domains d,
                    sys_users su,
                    hosting h
                where
                    d.id = h.dom_id
                    and su.id = h.sys_user_id
            );
    }
    else {
        $sql = qq(
                select
                    su.login as name,
                    d.name as domain,
                    d.id as domain_id,
                    d.cl_id as client_id
                from
                    domains d,
                    sys_users su,
                    hosting h
                where
                    su.id = h.sys_user_id
                    and h.dom_id = d.id
                    and d.webspace_id = 0
            );
    }

    my $output = $self->psasqlcmd($sql) or die "failed to execute: $sql";
    foreach ( split( m{\n}, $output ) ) {
        chomp;
        if (m{ \A (\S+) \s+ (\S+) }xms) {
            $plesk_domains_and_users{$2} = $1;
        }
    }

    return \%plesk_domains_and_users;
}

sub check_if_is_smb10 {
    my ($self) = @_;

    opendir( my $dh, '/etc/sw/keys/keys' );
    my @dir_contents = grep { !/^\.\.?$/ } readdir $dh;
    closedir $dh;

    my $is_smb10 = 0;
    if (@dir_contents) {
        my $plesk_key = pop @dir_contents;    # what if there is more than 1 key?

        open my $key_fh, '<', "/etc/sw/keys/keys/$plesk_key";
        while (<$key_fh>) {
            if (/Small Business Panel 10/) {
                $is_smb10 = 1;
                last;
            }
        }
        close $key_fh;
    }

    return $is_smb10;
}

sub _get_adminpass {
    my ($self) = @_;

    my $psa_pass_fh;

    if ( $self->{'psa1'} ) {
        open( $psa_pass_fh, '<', "/usr/local/plesk/admin/conf/admin.conf" );
    }
    else {
        open( $psa_pass_fh, '<', "/etc/psa/.psa.shadow" );
    }

    my $adminpass = readline($psa_pass_fh);
    chomp($adminpass);

    close($psa_pass_fh);

    return $adminpass;
}

sub get_databases {
    my ( $self, $domain_id ) = @_;

    $domain_id = int($domain_id);

    my $query;

    if ( $self->{'psaversion'}->{'major'} <= 7 ) {
        $query = qq(
            select
                db.name,
                db.type,
                dbu.login as user,
                ac.password as pass
            from
                data_bases db,
                db_users dbu,
                accounts ac
            where
                ac.id = dbu.account_id
                and dbu.db_id = db.id
                and db.dom_id = $domain_id
        );
    }
    else {
        $query = qq(
            select
                db.name,
                db.type,
                db.default_user_id,
                ds.host,
                ds.port,
                ds.admin_login as user,
                ds.admin_password as pass
            from
                data_bases db,
                DatabaseServers ds
            where
                ds.id = db.db_server_id
                and db.dom_id = $domain_id
        );
    }

    my $dbs = $self->psasqlcmd_hashref($query);
    #
    # It seems the actual password for the admin@localhost accounts stored
    # in the psa.DatabaseServers table is not stored, so update each row
    # fetched with the password retrieved from the Plesk environment prior
    # to returning.
    #
    foreach my $db ( @{$dbs} ) {
        next unless $db->{'user'} eq 'admin';
        next unless $db->{'host'} eq 'localhost';

        $db->{'pass'} = $self->{'adminpass'};
    }

    return $dbs;
}

sub psasqlcmd_hashref {
    my ( $self, $query ) = @_;
    my $data;

    my $handle = $self->get_psasqlcmd_handle($query);

    while ( read( $handle->{'out'}, my $buf, 4096 ) ) {
        $data .= $buf;
    }

    my @result_set;

    return \@result_set unless $data;

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

    foreach my $row (@mysql_data) {
        my @row = $self->_lexer($row);

        my $results = {};
        my $count   = 0;

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

        push @result_set, $results;
    }

    close $handle->{'out'};
    waitpid( $handle->{'pid'}, 0 );

    return \@result_set;
}

sub _lexer {
    my ( $self, $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;
}

# Usage
# perl -MJSON -MPlesk::DatabaseDumper dump_databases_and_users.pl

# In order for servers with this script to get your new changes,
# you must increment this version number.
our $VERSION = '1.2';

#
## No USE statements so this runs on other platforms
## We must require everything in AFTER the version line
##
#
sub main {
    my (@args) = @_;

    if ( @args && grep( m/version/i, @args ) ) {
        print "dump_databases_and_users VERSION $VERSION\n";
        return 0;
    }
    my $dumper     = Plesk::DatabaseDumper->new();
    my $master_map = $dumper->dump_users_and_dbs();

    print JSON::PP::encode_json($master_map);
    return 0;
}

exit main(@ARGV) unless caller();

1;
