File Coverage

blib/lib/SVN/Access.pm

Criterion	Covered	Total	%
statement	189	235	80.4
branch	105	136	77.2
condition	14	21	66.6
subroutine	24	25	96.0
pod	17	18	94.4
total	349	435	80.2

package SVN::Access;

use SVN::Access::Group;
use SVN::Access::Resource;

use open ':encoding(utf8)';

use 5.006001;
use strict;
use warnings;

our $VERSION = '0.11';

sub new {
    my ($class, %attr) = @_;
    my $self = bless(\%attr, $class);

    # it's important that we have this.
    die "No ACL file specified!" unless $attr{acl_file};

    if (-e $attr{acl_file}) {
        # parse the file in.
        $self->parse_acl;
    } else {
        # empty acl.
        $attr{acl} = {};
    }
    return $self;
}

sub parse_acl {
    my ($self) = @_;
    open(ACL, '<', $self->{acl_file}) or die "Can't open SVN Access file " . $self->{acl_file} . ": $!";
    my $current_resource;
    my $statement;
    while (my $line = ) {
        # ignore comments (properly defined)
        next if $line =~ /^#/;
        $line =~ s/\s*#.*$// unless $self->{pedantic};

        # get rid of trailing whitespace.
        $line =~ s/[\s\r\n]+$//;
        next unless $line;

        # handle line continuations
        if ($line =~ /^\s+(.+)$/) {
            $statement .= " $1";
        } else {
            $statement = $line;
        }

        # lookahead and see if the next line is a line continuation
        my $pos = tell(ACL);
        my $nextline = ;
        seek(ACL, $pos, 0); # rewind the filehandle to where we were.
        if ($nextline && $nextline =~ /^[ \t]+\S/) {
            next;
        }

        next unless $statement;

        if ($statement =~ /^\[\s*(.+?)\s*\]$/) {
            # this statement is defining a new resource.
            $current_resource = $1;
            unless ($current_resource =~ /^(?:groups|aliases)$/) {
                $self->add_resource($current_resource);
            }
        } else {
            # both groups and resources need this parsed.
            my ($k, $v) = $statement =~ /^(.+?)\s*=\s*(.*?)$/;

            # if the previous split didn't work, there's a syntax error
            unless ($k) {
                warn "Unrecognized line $statement\n";
                next;
            }

            if ($current_resource eq "groups") {
                # this is a group
                $self->add_group($k, split(/\s*,\s*/, $v));
            } elsif ($current_resource eq "aliases") {
                # aliases are simple k=v, so let's just store them in ourselves.
                $self->add_alias($k, $v);
            } else {
                # this is a generic resource
                unless ($v =~ /^[rw\s]*$/) {
                    warn "Invalid character in authz rule $v\n";
                }
                if (my $resource = $self->resource($current_resource)) {
                    $resource->authorize($k => $v);
                } else {
                    $self->add_resource($current_resource, $k, $v);
                }
            }
        }

        $statement = undef;
    }

    # make sure this isn't empty.
    unless (ref($self->{acl}->{aliases}) eq "HASH") {
        $self->{acl}->{aliases} = {};
    }

    close (ACL);
}

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

    # Check for references to undefined groups (Thanks Jesse!)
    my (%groups, @errors);
    if ($self->groups) {
        # gather groups first, in case there are forward refs
        foreach my $group ($self->groups) {
            $groups{$group->name}++;
            # check for loops
            local $SIG{__WARN__} = sub { push @errors, @_; };
            my @g = $self->resolve('@' . $group->name);
        }
        foreach my $group ($self->groups) {
            foreach my $k ($group->members) {
                if ( $k =~ /^@(.*)/ ) {
                    unless ( $groups{$1} ) {
                        push(@errors, "[error] An authz rule (" . $group->name. ") refers to group '$1', which is undefined");
                    }
                } elsif ( $k =~ /^&(.*)/ ) {
                    unless ( $self->aliases->{$1} ) {
                        push(@errors, "[error] An authz rule (" . $group->name . ") refers to alias '$1', which is undefined");
                    }
                }
            }
        }
    }

    foreach my $resource ($self->resources) {
        if (defined($resource) && $resource->authorized) {
            foreach my $k (keys %{$resource->authorized}) {
                if ( $k =~ /^@(.*)/ ) {
                    unless ( $groups{$1} ) {
                        push(@errors, "[error] An authz rule (" . $resource->name . ") refers to group '\@$1', which is undefined");
                    }
                } elsif ( $k =~ /^&(.*)/ ) {
                    unless ( $self->aliases->{$1} ) {
                        push(@errors, "[error] An authz rule (" . $resource->name . ") refers to alias '\&$1', which is undefined");
                    }
                }
            }
        }
    }

    chomp @errors;
    return scalar(@errors) ? join("\n", @errors) : undef;
}

sub write_acl {
    my ($self, $out) = @_;

    # verify the ACL has no errors before writing it out
    if (my $error = $self->verify_acl) {
        die "Error found in ACL:\n$error\n";
    }

    if (ref \$out eq "GLOB" or ref $out) {
        *ACL = $out;
    }
    else {
        $out = $self->{acl_file} unless $out;
        open (ACL, '>', $out) or warn "Can't open ACL file " . $out . " for writing: $!\n";
    }

    # aliases now supported!
    if (scalar(keys %{$self->aliases})) {
        print ACL "[aliases]\n";
        foreach my $alias (keys %{$self->aliases}) {
            print ACL $alias . " = " . $self->aliases->{$alias} . "\n";
        }
        print ACL "\n";
    }

    # groups now second to aliases
    if ($self->groups) {
        print ACL "[groups]\n";
        foreach my $group ($self->groups) {
            print ACL $group->name . " = " . join(', ', $group->members) . "\n";
        }
        print ACL "\n";
    }

    foreach my $resource ($self->resources) {
        if (defined($resource) && $resource->authorized) {
            print ACL "[" . $resource->name . "]\n";
            while (my ($k, $v) = (each %{$resource->authorized})) {
                print ACL "$k = $v\n";
            }
            print ACL "\n";
        }
    }

    close(ACL);
}

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

    # verify the ACL has no errors before writing it out
    if (my $error = $self->verify_acl) {
        die "Error found in ACL:\n$error\n";
    }

    my $max_len = 0;

    # Compile a list of names that will appear on the left side
    my @names;
    if (scalar(keys %{$self->aliases})) {
        foreach my $alias (keys %{$self->aliases}) {
            push(@names, $alias);
        }
    }

    if ($self->groups) {
        for ($self->groups) {
            push(@names, $_->name);
        }
    }
    if ($self->resources) {
        for ($self->resources) {
            push(@names, keys(%{$_->authorized}));
        }
    }

    # Go through that list looking for the longest name
    for (@names) {
        $max_len = length($_) >= $max_len ? length($_) : $max_len;
    }

    open (ACL, '>', $self->{acl_file}) or warn "Can't open ACL file " . $self->{acl_file} . " for writing: $!\n";

    # aliases now fully supported!
    if (scalar(keys %{$self->aliases})) {
        print ACL "[aliases]\n";
        foreach my $alias (keys %{$self->aliases}) {
            print ACL $alias . " " x ($max_len - length($alias)) . " = " . $self->aliases->{$alias} . "\n";
        }
        print "\n";
    }

    # groups now second?
    if ($self->groups) {
        print ACL "[groups]\n";
        foreach my $group ($self->groups) {
            print ACL $group->name . " " x ($max_len - length($group->name)) . " = " . join(', ', $group->members) . "\n";
        }
        print "\n";
    }

    foreach my $resource ($self->resources) {
        if (defined($resource) && $resource->authorized) {
            print ACL "[" . $resource->name . "]\n";
            while (my ($k, $v) = (each %{$resource->authorized})) {
                print ACL "$k" . " " x ($max_len - length($k)) . " = $v\n";
            }
            print ACL "\n";
        }
    }
    close(ACL);
}

sub add_alias {
    my ($self, $alias_name, $aliased) = @_;
    $self->{acl}->{aliases}->{$alias_name} = $aliased;
}

sub remove_alias {
    my ($self, $alias_name) = @_;
    delete $self->{acl}->{aliases}->{$alias_name};
}

sub alias {
    my ($self, $alias_name) = @_;
    if (exists ($self->{acl}->{aliases}->{$alias_name})) {
        return $self->{acl}->{aliases}->{$alias_name};
    }
    return undef;
}

sub aliases {
    my ($self) = @_;
    # give em something if we got nothing!
    unless (ref($self->{acl}->{aliases}) eq "HASH") {
        $self->{acl}->{aliases} = {};
    }
    return $self->{acl}->{aliases};
}

sub add_resource {
    my ($self, $resource_name, @access) = @_;
    if ($resource_name eq "name") {
        $resource_name = shift(@access);
    }

    my @acl;
    foreach my $entry (@access) {
        next if $entry eq "authorized";

        if (ref($entry) eq "HASH") {
            # unpack the hashref to a list.
            foreach my $key (keys %$entry) {
                push(@acl, $key, $entry->{$key});
            }
        } elsif (ref($entry) eq "ARRAY") {
            push(@acl, @$entry);
        } else {
            push(@acl, $entry);
        }
    }

    if ($self->resource($resource_name)) {
        die "Can't add new resource $resource_name: resource already exists!\n";
    } elsif ($resource_name !~ /^(?:\S+\:)?\/.*$/) { # Thanks Matt
        die "Invalid resource format in $resource_name! (format 'repo:/path')!\n";
    } else {
        my $resource = SVN::Access::Resource->new(
            name => $resource_name,
            authorized => \@acl,
        );
        push(@{$self->{acl}->{resources}}, $resource);
        return $resource;
    }
}

sub remove_resource {
    my ($self, $resource_name) = @_;
    my @resources;
    foreach my $resource ($self->resources) {
        push(@resources, $resource) unless $resource->name eq $resource_name;
    }
    $self->{acl}->{resources} = scalar(@resources) ? \@resources : undef;
}

sub resources {
    my ($self) = @_;
    if (ref($self->{acl}->{resources}) eq "ARRAY") {
        return (@{$self->{acl}->{resources}});
    } else {
        return (undef);
    }
}

sub resource {
    my ($self, $resource_name) = @_;
    foreach my $resource ($self->resources) {
        return $resource if defined($resource) && $resource->name eq $resource_name;
    }
    return undef;
}

sub add_group {
    my ($self, $group_name, @initial_members) = @_;

    # get rid of the @ symbol.
    $group_name =~ s/\@//g unless $self->{pedantic};

    if ($self->group($group_name)) {
        die "Can't add new group $group_name: group already exists!\n";
    } else {
        my $group = SVN::Access::Group->new(
            name        =>      $group_name,
            members     =>      \@initial_members,
        );
        push(@{$self->{acl}->{groups}}, $group);
        return $group;
    }
}

sub remove_group {
    my ($self, $group_name) = @_;
    my @groups;

    # get rid of the @ symbol.
    $group_name =~ s/\@//g;
    foreach my $group ($self->groups) {
        push(@groups, $group) unless $group->name eq $group_name;
    }

    $self->{acl}->{groups} = scalar(@groups) ? \@groups : undef;
}

sub groups {
    my ($self) = @_;
    if (ref($self->{acl}->{groups}) eq "ARRAY") {
        return (@{$self->{acl}->{groups}});
    } else {
        return (undef);
    }
}

sub group {
    my ($self, $group_name) = @_;
    foreach my $group ($self->groups) {
        return $group if defined($group) && $group->name eq $group_name;
    }
    return undef;
}

sub resolve {
    my $self = shift;
    my @res;
    my $seen = (ref $_[$#_] eq "ARRAY" ? pop @_ : []);

    foreach my $e (@_) {
        if ($e =~ /^\@(.+)/) {
            # check for loops
            if (grep($_ eq $e, @$seen)) {
                warn "Error: group loop detected ",join(", ", @$seen, $e),"\n";
                return undef;
            }
            push @$seen, $e;
            push @res, map $self->resolve($_, $seen),
                           $self->group($1)->members()
                if $self->group($1);
            pop @$seen;
        } elsif ($e =~ /^\&(.+)/) {
            push @res, map $self->resolve($_), $self->alias($1)
                if $self->alias($1);
        } else {
            push @res, $e;
        }
    }

    return @res;
}

1;
__END__