view release on metacpan or  search on metacpan

lib/App/KGB/Client.pm  view on Meta::CPAN

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

    my $self = $class->SUPER::new(
        {   use_color => 1,
            %$init,
        }
    );

    print "Configuration: " . YAML::Dump(@_) if $self->verbose;

    defined( $self->repo_id )
        or confess "'repo_id' is mandatory";
    $self->br_mod_re( [ $self->br_mod_re // () ] )
        if not ref( $self->br_mod_re );
    $self->mod_br_re( [ $self->mod_br_re // () ] )
        if not ref( $self->mod_br_re );

    $self->servers( [] ) unless defined( $self->servers );

    ref( $self->servers ) and ref( $self->servers ) eq 'ARRAY'
        or confess "'servers' must be an arrayref";

    @{ $self->servers } or confess "No 'servers' specified";

    if ( $self->status_dir ) {
        if ( not -e $self->status_dir ) {
            warn "Status directory ".$self->status_dir." doesn't exist.\n";
            $self->status_dir(undef);
        }
        elsif ( not -d $self->status_dir ) {
            warn $self->status_dir." is not a directory\n";
            $self->status_dir(undef);
        }
    }

    $self->protocol('auto') unless defined( $self->protocol );

    return $self;
}

=head1 METHODS

=over

=item detect_branch_and_module ( $changes )

Given a set of changes (an arrayref of L<App::KGB::Change> objects), runs all
the regular expressions as listed in B<br_mod_re> and B<mod_br_re> and if a
regular expression that matches all the changed paths and returns the branch
and module.

    ( $branch, $module ) = $client->detect_branch_and_module($changes);

=cut

sub _run_matches {
    my ( $safe, $changes, $res, $swap ) = @_;

    for my $re (@$res) {
        $re =~ s{,}{\\,}g;    # escape commas
        my $matching = "m,$re,; " . ( $swap ? '($2,$1)' : '($1,$2)' );

        local $_ = $changes->path;
        my ( $branch, $module ) = $safe->reval($matching);
        die "Error while evaluating `$re': $@" if $@;

        if ( defined($branch) and defined($module) ) {
            return ( $re, $branch, $module );
        }
    }
    return ( undef, undef, undef );
}

sub detect_branch_and_module {
    my ( $self, $changes ) = @_;
    return () unless $self->br_mod_re;

    require Safe;
    my $safe = Safe->new;
    $safe->permit_only(
        qw(padany lineseq match const leaveeval
            rv2gv rv2sv pushmark list warn)
    );

    my ( $branch, $module, $matched_re );

    # for a successful branch/module extraction, we require that all the
    # changes share the same branch/module
    for my $c (@$changes) {
        my ( $change_branch, $change_module );

        ( $matched_re, $change_branch, $change_module )
            = _run_matches( $safe, $c, $self->br_mod_re, 0 );
        ( $matched_re, $change_branch, $change_module )
            = _run_matches( $safe, $c, $self->mod_br_re, 1 )
            unless $matched_re
            and defined($change_branch)
            and defined($change_module);

        # some change cannot be tied to a branch and a module?
        if ( !defined( $change_branch // $change_module ) ) {
            $branch = $module = $matched_re = undef;
            last;
        }

        if ( defined($branch) ) {

            # this change is for a different branch/module?
            if ( $branch ne $change_branch or $module ne $change_module ) {
                $branch = $module = $matched_re = undef;
                last;
            }
        }
        else {

            # first change, store branch and module
            $branch = $change_branch;
            $module = $change_module;
        }
    }