use 5.008_005;
our $VERSION = '1.003';
sub new {
my($class, %args) = @_;
my $self = {
dbh => undef,
need_disconnect => 0,
};
if (exists $args{dbh}) {
$self->{dbh} = delete $args{dbh};
} else {
if (!$args{hostname} && !$args{socket}) {
Carp::croak("missing mandatory args: hostname or socket");
}
my $dsn = "DBI:mysql:";
for my $p (
[qw(hostname hostname)],
[qw(port port)],
[qw(socket mysql_socket)],
) {
my $arg_key = $p->[0];
my $param_key = $p->[1];
if ($args{$arg_key}) {
$dsn .= ";$param_key=$args{$arg_key}";
}
}
$self->{need_disconnect} = 1;
$self->{dbh} = DBI->connect(
$dsn,
$args{user}||'',
$args{password}||'',
{
AutoCommit => 0,
},
) or Carp::croak("$DBI::errstr ($DBI::err)");
}
$self->{server_version} = exists $self->{dbh}->{mysql_serverversion} ? $self->{dbh}->{mysql_serverversion} : 0;
return bless $self, $class;
}
sub parse {
my $self = shift;
my %grants;
my $rset = $self->{dbh}->selectall_arrayref('SELECT user, host FROM mysql.user');
for my $user_host (@$rset) {
my ($user, $host) = @{$user_host};
my $quoted_user_host = $self->quote_user($user, $host);
my $rset = $self->{dbh}->selectall_arrayref("SHOW GRANTS FOR ${quoted_user_host}");
my @stmts;
for my $rs (@$rset) {
push @stmts, @{$rs};
}
if ($self->{server_version} >= 50706) {
my $rset = $self->{dbh}->selectall_arrayref("SHOW CREATE USER ${quoted_user_host}");
for my $rs (@$rset) {
push @stmts, @{$rs};
}
}
%grants = (%grants, %{ parse_stmts(\@stmts) });
}
return \%grants;
}
sub parse_stmts {
my $stmts = shift;
my @grants = ();
for my $stmt (@$stmts) {
my $parsed = {
with => '',
require => '',
identified => '',
privs => [],
object => '',
user => '',
host => '',
};
if ($stmt =~ s/\s+IDENTIFIED WITH\s+'([^']+)'\s+AS\s+(.+?)\s+//) {
$parsed->{identified} = "PASSWORD $2";
}
if ($stmt =~ s/\s+IDENTIFIED WITH\s+'([^']+)'\s+//) {
$parsed->{identified} = "";
}
if ($stmt =~ /\ACREATE\s+USER\s+'(.*)'\@'(.+)'/) {
$parsed->{user} = $1;
$parsed->{host} = $2;
}
if ($stmt =~ s/\s+WITH\s+(.+?)\z//) {
$parsed->{with} = $1;
}
if ($stmt =~ s/\s+REQUIRE\s+(.+?)\z//) {
$parsed->{require} = $1;
}
if ($stmt =~ s/\s+IDENTIFIED BY\s+(.+?)\z//) {
$parsed->{identified} = $1;
}
if ($stmt =~ /\AGRANT\s+(.+?)\s+ON\s+(.+?)\s+TO\s+'(.*)'\@'(.+)'\z/) {
$parsed->{privs} = parse_privs($1);
$parsed->{object} = $2;
$parsed->{user} = $3;
$parsed->{host} = $4;
}
push @grants, $parsed;
}
return pack_grants(@grants);
}
sub pack_grants {
my @grants = @_;
my $packed;
for my $grant (@grants) {
my $user = delete $grant->{user};
my $host = delete $grant->{host};
my $user_host = join '@', $user, $host;
my $object = delete $grant->{object};
my $identified = delete $grant->{identified};
my $required = delete $grant->{require};
unless (exists $packed->{$user_host}) {
$packed->{$user_host} = {
user => $user,
host => $host,
objects => {},
options => {
required => '',
identified => '',
},
};
}
$packed->{$user_host}{objects}{$object} = $grant if (scalar(@{ $grant->{privs} || []}) > 0);
$packed->{$user_host}{options}{required} = $required if $required;
if ($identified) {
$packed->{$user_host}{options}{identified} = $identified;
}
}
return $packed;
}
sub quote_user {
my $self = shift;
my($user, $host) = @_;
sprintf q{%s@%s}, $self->{dbh}->quote($user), $self->{dbh}->quote($host);
}
sub parse_privs {
my $privs = shift;
$privs .= ',';
my @priv_list = ();
while ($privs =~ /\G([^,(]+(?:\([^)]+\))?)\s*,\s*/g) {
push @priv_list, $1;
}
return \@priv_list;
}
sub DESTROY {
my $self = shift;
if ($self->{need_disconnect}) {
$self->{dbh} && $self->{dbh}->disconnect;
}
}
1;
