CheckStructure.pm

use strict;
use warnings;

package SVN::Hooks::CheckStructure;
# ABSTRACT: Check the structure of a repository.

use Carp;
use Data::Util qw(:check);
use SVN::Hooks;

use Exporter qw/import/;
my $HOOK = 'CHECK_STRUCTURE';
our @EXPORT = ($HOOK, 'check_structure');

=for Pod::Coverage pre_commit

=head1 SYNOPSIS

This SVN::Hooks plugin checks if the files and directories added to
the repository are allowed by its structure definition. If they don't,
the commit is aborted.

It's active in the C<pre-commit> hook.

It's configured by the following directive.

=head2 CHECK_STRUCTURE(STRUCT_DEF)

This directive enables the checking, causing the commit to abort if it
doesn't comply.

The STRUCT_DEF argument specify the repository strucure with a
recursive data structure consisting of one of:

=over

=item ARRAY REF

An array ref specifies the contents of a directory. The referenced
array must contain a pair number of elements. Each pair consists of a
NAME_DEF and a STRUCT_DEF. The NAME_DEF specifies the name of the
component contained in the directory and the STRUCT_DEF specifies
recursively what it must be.

The NAME_DEF specifies a name in one of these ways:

=over

=item STRING

A string specifies a name directly.

=item REGEXP

A regexp specifies the class of names that match it.

=item NUMBER

A number may be used as an else-clause. A positive number means that
any name not yet matched by the previous pair must conform to the
associated STRUCT_DEF.

A negative number means that no name will do and signals an error. In
this case, if the STRUCT_DEF is a string it is used as a help message
shown to the user.

=back

If no NAME_DEF matches the component being looked for, then it is a
structure violation and the commit fails.

=item STRING

A string must be one of 'FILE' and 'DIR', specifying what the current
component must be.

=item NUMBER

A positive number simply tells that whatever the current component is
is ok and finishes the check successfully.

A negative number tells that whatever the current component is is a
structure violation and aborts the commit.

=back

Now that we have this semi-formal definition off the way, let's try to
understand it with some examples.

	my $tag_rx    = qr/^[a-z]+-\d+\.\d+$/; # e.g. project-1.0
	my $branch_rx = qr/^[a-z]+-/;	# must start with letters and hifen
	my $project_struct = [
	    'META.yml'    => 'FILE',
	    'Makefile.PL' => 'FILE',
	    ChangeLog     => 'FILE',
	    LICENSE       => 'FILE',
	    MANIFEST      => 'FILE',
	    README        => 'FILE',
	    t => [
		qr/\.t$/  => 'FILE',
	    ],
	    lib => 'DIR',
	];

	CHECK_STRUCTURE(
	    [
		trunk => $project_struct,
		branches => [
		    $branch_rx => $project_rx,
		],
		tags => [
		    $tag_rx => $project_rx,
		],
	    ],
	);

The structure's first level consists of the three usual directories:
C<trunk>, C<tags>, and C<branches>. Anything else in this level is
denied.

Below the C<trunk> we allow some usual files and two directories only:
C<lib> and C<t>. Below C<trunk/t> we may allow only test files with
the C<.t> extension and below C<lib> we allow anything.

We require that each branch and tag have the same structure as the
C<trunk>, which is made easier by the use of the C<$project_struct>
variable. Moreover, we impose some restrictions on the names of the
tags and the branches.

=cut

my $Structure;

sub CHECK_STRUCTURE {
    ($Structure) = @_;

    PRE_COMMIT(\&pre_commit);

    return 1;
}

sub _check_structure {
    my ($structure, $path) = @_;

    @$path > 0 or croak "Can't happen!";

    if (is_string($structure)) {
	if ($structure eq 'DIR') {
	    return (1) if @$path > 1;
	    return (0, "the component ($path->[0]) should be a DIR in");
	} elsif ($structure eq 'FILE') {
	    return (0, "the component ($path->[0]) should be a FILE in") if @$path > 1;
	    return (1);
	} elsif (is_integer($structure)) {
	    return (1) if $structure;
	    return (0, "invalid path");
	} else {
	    return (0, "syntax error: unknown string spec ($structure), while checking");
	}
    } elsif (is_array_ref($structure)) {
	return (0, "syntax error: odd number of elements in the structure spec, while checking")
	    unless scalar(@$structure) % 2 == 0;
	return (0, "the component ($path->[0]) should be a DIR in")
	    unless @$path > 1;
	shift @$path;
	# Return ok if the directory doesn't have subcomponents.
	return (1) if @$path == 1 && length($path->[0]) == 0;

	for (my $s=0; $s<$#$structure; $s+=2) {
	    my ($lhs, $rhs) = @{$structure}[$s, $s+1];
	    if (is_string($lhs)) {
		if ($lhs eq $path->[0]) {
		    return _check_structure($rhs, $path);
		} elsif ($lhs =~ /^\d+$/) {
		    if ($lhs) {
			return _check_structure($rhs, $path);
		    } elsif (is_string($rhs)) {
			return (0, "$rhs, while checking");
		    } else {
			return (0, "syntax error: the right hand side of a number must be string, while checking");
		    }
		}
	    } elsif (is_rx($lhs)) {
		if ($path->[0] =~ $lhs) {
		    return _check_structure($rhs, $path);
		}
	    } else {
		my $what = ref $lhs;
		return (0, "syntax error: the left hand side of arrays in the structure spec must be scalars or qr/Regexes/, not $what, while checking");
	    }
	}
	return (0, "the component ($path->[0]) is not allowed in");
    } else {
	my $what = ref $structure;
	return (0, "syntax error: invalid reference to a $what in the structure spec, while checking");
    }
}

=head1 EXPORT

=head2 check_structure(STRUCT_DEF, PATH)

SVN::Hooks::CheckStructure exports a function to allow for the
verification of path structures outside the context of a Subversion
hook. (It would probably be better to take this function to its own
module and use that module here. We'll take care of that eventually.)

The function check_structure takes two arguments. The first is a
STRUCT_DEF exactly the same as specified for the CHECK_STRUCTURE
directive above. The second is a PATH to a file which will be checked
against the STRUCT_DEF.

The function returns true if the check succeeds and dies with a proper
message otherwise.

The funcion is intended to check paths as they're shown by the 'svn
ls' command, i.e., with no leading slashes and with a trailing slash
to indicate directories. The leading slash is assumed if it's missing,
but the trailing slash is needed to indicate directories.

=cut

sub check_structure {
    my ($structure, $path) = @_;
    $path = "/$path" unless $path =~ m@^/@; # make sure it's an absolute path
    my @path = split '/', $path, -1; # preserve trailing empty components
    my ($code, $error) = _check_structure($structure, \@path);
    croak "$error: $path\n" if $code == 0;
    return 1;
}

sub pre_commit {
    my ($svnlook) = @_;

    my @errors;

    foreach my $added ($svnlook->added()) {
	# Split the $added path in its components. We prefix $added
	# with a slash to make it look like an absolute path for
	# _check_structure. The '-1' is to preserve trailing empty
	# components so that we can differentiate directory paths from
	# file paths.
	my @added = split '/', "/$added", -1;
	my ($code, $error) = _check_structure($Structure, \@added);
	push @errors, "$error: $added" if $code == 0;
    }

    croak join("\n", "$HOOK:", @errors), "\n"
	if @errors;

    return;
}

1; # End of SVN::Hooks::CheckStructure