File Coverage

blib/lib/Pg/Priv.pm

Criterion	Covered	Total	%
statement	56	56	100.0
branch	18	20	90.0
condition	6	7	85.7
subroutine	27	27	100.0
pod	22	22	100.0
total	129	132	97.7

package Pg::Priv;

use 5.8.0;
use strict;
use warnings;

our $VERSION = '0.12';

my %label_for = (
    r => 'SELECT',
    w => 'UPDATE',
    a => 'INSERT',
    d => 'DELETE',
    D => 'TRUNCATE',
    x => 'REFERENCE',
    t => 'TRIGGER',
    X => 'EXECUTE',
    U => 'USAGE',
    C => 'CREATE',
    c => 'CONNECT',
    T => 'TEMPORARY',
);

my %priv_for = map { $label_for{$_} => $_ } keys %label_for;

# Some aliases.
$priv_for{TEMP} = 'T';

sub parse_acl {
    my ($class, $acl, $quote) = @_;
    return unless $acl;

    my @privs;
    my $prev;
    for my $perms (@{ $acl }) {
        # http://www.postgresql.org/docs/current/static/sql-grant.html#SQL-GRANT-NOTES
        my ($role, $privs, $by) = $perms =~ m{^"?(?:(?:group\s+)?([^=]+))?=([^/]+)/(.*)};
        $prev = $privs eq '*' ? $prev : $privs;
        $role ||= 'public';
        push @privs, $class->new(
            to    => $quote ? _quote_ident($role) : $role,
            by    => $quote ? _quote_ident($by)   : $by,
            privs => $prev,
        )
    }
    return wantarray ? @privs : \@privs;
}

sub new {
    my $class = shift;
    my $self = bless { @_ } => $class;
    $self->{parsed} = { map { $_ => 1 } split //, $self->{privs} || '' };
    return $self;
}

sub to    { shift->{to}  }
sub by    { shift->{by}    }
sub privs { shift->{privs} }
sub labels {
    wantarray ? map { $label_for{$_} } keys %{ shift->{parsed} }
              : [ map { $label_for{$_} } keys %{ shift->{parsed} } ];
}
sub can   {
    my $can = shift->{parsed} or return;
    for my $what (@_) {
        return unless $can->{ length $what == 1 ? $what : $priv_for{uc $what} };
    }
    return 1;
}

sub can_select    { shift->can('r') }
sub can_read      { shift->can('r') }
sub can_update    { shift->can('w') }
sub can_write     { shift->can('w') }
sub can_insert    { shift->can('a') }
sub can_append    { shift->can('a') }
sub can_delete    { shift->can('d') }
sub can_reference { shift->can('x') }
sub can_trigger   { shift->can('t') }
sub can_execute   { shift->can('X') }
sub can_usage     { shift->can('U') }
sub can_create    { shift->can('C') }
sub can_connect   { shift->can('c') }
sub can_temporary { shift->can('T') }
sub can_temp      { shift->can('T') }

# ack ' RESERVED_KEYWORD' src/include/parser/kwlist.h | awk -F '"' '{ print "    " $2 }'
my %reserved = ( map { $_ => undef } qw(
    all
    analyse
    analyze
    and
    any
    array
    as
    asc
    asymmetric
    both
    case
    cast
    check
    collate
    column
    constraint
    create
    current_catalog
    current_date
    current_role
    current_time
    current_timestamp
    current_user
    default
    deferrable
    desc
    distinct
    do
    else
    end
    except
    false
    fetch
    for
    foreign
    from
    grant
    group
    having
    in
    initially
    intersect
    into
    leading
    limit
    localtime
    localtimestamp
    new
    not
    null
    off
    offset
    old
    on
    only
    or
    order
    placing
    primary
    references
    returning
    select
    session_user
    some
    symmetric
    table
    then
    to
    trailing
    true
    union
    unique
    user
    using
    variadic
    when
    where
    window
    with
));

sub _is_reserved($) {
    exists $reserved{+shift};
}

sub _quote_ident($) {
    my $role = shift;
    # Can avoid quoting if ident starts with a lowercase letter or underscore
    # and contains only lowercase letters, digits, and underscores, *and* is
    # not any SQL keyword. Otherwise, supply quotes.
    return $role if $role =~ /^[_a-z](?:[_a-z0-9]+)?$/ && !_is_reserved $role;
    $role =~ s/"/""/g;
    return qq{"$role"};
}

1;
__END__