view release on metacpan or  search on metacpan

lib/SVN/Deploy.pm  view on Meta::CPAN

    my %args = $self->_getargs(@_) or return;

    my $root_href = $self->_svn('ls', $self->{repo}, 'HEAD', 0)
        or return;

    unless ( exists($root_href->{$args{category}}) ) {
        $self->{lasterr} = "Category $args{category} does not exist";
        return;
    }

    my $old = join('/', $self->{repo}, $args{category});
    my $new = join('/', $self->{repo}, $args{new_name});

    _log "renaming >>$old<< to >>$new<<";
    $self->_svn('move', $old, 'HEAD', $new, 1)
        or return;

    return(1);
}


# add entry to history log
# an entry consists of a set of properties:
my @hist_values = qw/
    target version reference_id reference_data action
/;
sub _hist_add {
    my($self, %args) = @_;

    my $cat_url  = join('/', $self->{repo}, $args{category});
    my $prod_url = join('/', $cat_url, $args{product});

    my $prod_tmp = catdir(
        $self->{tempdir},
        join('-', $args{category}, $args{product}, 'props'),
    );

    if ( -e $prod_tmp ) {
        _log "updating $prod_tmp";
        $self->_svn('update', $prod_tmp, 'HEAD', 0);
    } else {
        _log "checking out '$prod_url' to $prod_tmp";
        $self->_svn('checkout', $prod_url, $prod_tmp, 'HEAD', 0)
            or return;
    }

    my $dir_save = getcwd();
    chdir($prod_tmp);

    $args{reference_id} ||= '';

    # serialize arbitrary external data
    if ( ref($args{reference_data}) ) {
        $args{reference_data}
            = encode_base64(nfreeze($args{reference_data}));
    }

    # setting svn properties
    for my $hv ( @hist_values ) {
        _log "setting property for $hv";
        $self->_svn('propset', "D:$hv", $args{$hv}, $prod_tmp, 0)
            or return;
    }

    _log "committing property changes";

    $self->_svn('log_msg', sub { ${$_[0]} = $args{comment} } )
        if $args{comment};

    $self->_svn('commit', $prod_tmp, 0)
        or return;

    chdir($dir_save);

    return(1);
}


=head3 deploy_version

    $obj->deploy_version(
        category       => <category_name>,
        product        => <product_name>,
        version        => <revision>,
        target         => 'qa'|'prod',
        [reference_id   => <string data>,]
        [reference_data => <reference to serialize>,]
        [comment        => <log message>,]
    );

Deploy a previously build revision of a product to the specified
target.

Defined pre and post scripts (see L</"product_add">) are run before
respectively after deploy.

The reference parameters exist for storing external references
that can later be retrieved by the history functions for auditing
purposes. Typicaly this would be information on who did what on
whose request.

=cut

sub deploy_version {
    my $self = shift;
    my %args = $self->_getargs(@_) or return;

    # get release props
    my $props = $self->product_list(
        category => $args{category},
        product  => $args{product},
    )->{$args{product}};

    my $cat_url  = join('/', $self->{repo}, $args{category});
    my $prod_url = join('/', $cat_url, $args{product});

    unless ( exists($props->{$args{target}}) ) {
        $self->{lasterr} = "unknown target '$args{target}'";
        return;
    }

lib/SVN/Deploy.pm  view on Meta::CPAN

            = "parameter 'build' must contain an array ref";
        return;
    }

    for my $env (qw/qa prod/) {

        for my $key (qw/dest pre post/) {

            if (
                exists($args{cfg}{$env}{$key})
                and ref($args{cfg}{$env}{$key}) ne 'ARRAY'
            ) {
                $self->{lasterr}
                    = "$env: parameter '$key' must contain an array ref";
                return;
            }
        }

        if (
            exists($args{cfg}{$env}{dest})
            and @{ $args{cfg}{$env}{dest} } )
        {
            if ( @{ $args{cfg}{$env}{dest} } < @{ $args{cfg}{source} } ) {
                $self->{lasterr}
                    = "$env: destination for one ore more sources missing";
                return;
            }
        }
    }

    return(1);
}


# relocated set function for product_* methods
sub _product_set_params {
    my $self = shift;
    my %args = @_;

    my $prod_tmp = catdir(
        $self->{tempdir},
        join('-', $args{category}, $args{product}, 'props'),
    );

    if ( -e $prod_tmp ) {
        _log "updating $prod_tmp";
        $self->_svn('update', $prod_tmp, 'HEAD', 0)
            or return;
    } else {
        _log "checking out '$args{prod_url}' to $prod_tmp";
        $self->_svn('checkout', $args{prod_url}, $prod_tmp, 'HEAD', 0)
            or return;
    }

    my $dir_save = getcwd();
    chdir($prod_tmp);

    for my $param ( qw/build source/ ) {
        next unless $args{cfg}{$param};
        $self->_svn(
            'propset',
            $param,
            join("\n", @{ $args{cfg}{$param} }),
            $prod_tmp,
            0,
        ) or return;
    }

    for my $env (qw/qa prod/) {
        for my $key (qw/dest pre post/) {
            if ( $args{cfg}{$env}{$key} ) {
                $self->_svn(
                    'propset',
                    "${env}_$key",
                    join("\n", @{ $args{cfg}{$env}{$key} }),
                    $prod_tmp,
                    0,
                ) or return;
            }
        }
    }

    _log "committing property changes";
    $self->_svn('commit', $prod_tmp, 0) or return;

    chdir($dir_save);

    return(1);
}


=head3 product_add

    my %cfg = (
        build  => [
            '[os]perl build1.pl',
            '[os]perl build2.pl',
        ],
        source => [
            'svn://source_srv/source_repo/trunk/mypath1',
            'svn://source_srv/source_repo/trunk/mypath2',
        ],
        qa => {
            dest => [
                '[none]',
                '/mypath/to/qa/environment',
            ],
            pre  => ['[os]perl pre.pl'],
            post => ['[os]perl post.pl'],
        },
        prod => {
            dest => [
                '[none]',
                '/mypath/to/prod/environment',
            ],
            pre  => ['[os]perl pre.pl'],
            post => ['[os]perl post.pl'],
        },
    );

    $obj->product_add(
        category => <category_name>,
        product  => <product_name>,
        [cfg      => \%cfg,]
    );

Add a new product to a category. When specifying a destination, you
have to provide a destination for each specified source. '[none]' is a
valid destination, meaning the corresponding path of the deploy
repository will not be exported when calling $obj->deploy_version. You
can have more destinations than sources, e.g. when the build scripts
create additional directories.