File Coverage

blib/lib/CouchDB/Deploy/Process.pm

Criterion	Covered	Total	%
statement	24	83	28.9
branch	0	22	0.0
condition	0	13	0.0
subroutine	8	13	61.5
pod	5	5	100.0
total	37	136	27.2

package CouchDB::Deploy::Process;

use strict;
use warnings;

our $VERSION = $CouchDB::Deploy::VERSION;

use Carp            qw(confess);
use CouchDB::Client;
use File::Spec;
use Data::Compare   qw(Compare);
*_SAME = \&Compare;

sub new {
    my $class = shift;
    my $server = shift;
    return bless {
        server  => $server,
        client  => CouchDB::Client->new(uri => $server),
    }, $class;
}

sub createDBUnlessExists {
    my $self = shift;
    my $dbName = shift;

    $dbName .= '/' unless $dbName =~ m{/$};
    if (not $self->{client}->dbExists($dbName)) {
        $self->{db} = $self->{client}->newDB($dbName)->create();
        return 1;
    }
    else {
        $self->{db} = $self->{client}->newDB($dbName);
        return 0;
    }
}

use Data::Dumper;
sub addDocumentUnlessExistsOrSame {
    my $self = shift;
    my $id = shift;
    my $data = shift || {};
    my $newAttach = shift || {};

    my $db = $self->{db};
    if (not $db->docExists($id)) {
        $db->newDoc($id, undef, $data, $newAttach)->create();
        return 1;
    }
    else {
        my $doc = $db->newDoc($id)->retrieve();
        my $content = $doc->data;
        my $origAttach = $doc->attachments;
        if (keys %$origAttach and keys %$newAttach) {
            # compare attachments only if the rest isn't already different
            if (_SAME($content, $data)) {
                # the length is not the same, the names are not the same, or the content types are not the same
                if (
                    scalar(keys(%$origAttach)) != scalar(keys(%$newAttach)) or
                    grep({ not exists $origAttach->{$_} } keys %$newAttach) or
                    grep({ $origAttach->{$_}->{content_type} ne $newAttach->{$_}->{content_type} } keys %$newAttach)
                ) {
                    return _UPDATE($doc, $data, $newAttach);
                }
                # we have to fall back to comparing content
                else {
                    for my $att (keys %$newAttach) {
                        my $b64 = $newAttach->{$att}->{data};
                        if ($b64 ne $doc->toBase64($doc->fetchAttachment($att))) {
                            return _UPDATE($doc, $data, $newAttach);
                        }
                    }
                }
            }
            else {
                return _UPDATE($doc, $data, $newAttach);
            }
        }
        else {
            if (not _SAME($content, $data)) {
                return _UPDATE($doc, $data);
            }
        }
    }
    return 0;
}

sub _UPDATE {
    my ($doc, $data, $newAttach) = @_;
    $doc->attachments($newAttach);
    $doc->data($data);
    $doc->update();
    return 2;
}

sub addDesignDocUnlessExistsOrSame {
    my $self = shift;
    my $id = shift;
    my $data = shift;

    my $db = $self->{db};
    if (not $db->designDocExists($id)) {
        $db->newDesignDoc($id, undef, $data)->create();
        return 1;
    }
    else {
        my $dd = $db->newDesignDoc($id)->retrieve();
        if (not _SAME($dd->data, $data)) {
            $dd->data($data)->update();
            return 2;
        }
        return 0;
    }
}

sub getFile {
    my $self = shift;
    my $file = shift;

    $file = File::Spec->rel2abs(
        $file,
        File::Spec->rel2abs(
            File::Spec->catpath( (File::Spec->splitpath($0))[0,1], '' )
        )
    );
    open my $F, "<", $file or die "Can't open file: $file";
    my $content = do { local $/ = undef; <$F> };
    close $F;
    return CouchDB::Client::Doc->toBase64($content);
}

1;

=pod

=head1 NAME

CouchDB::Deploy::Process - The default processor for deploying to CouchDB

=head1 SYNOPSIS

    use CouchDB::Deploy;
    ...

=head1 DESCRIPTION

This module does the actual dirty job of deploying to CouchDB. Other backends could
replace it (though that's not supported yet) and it can be used by other frontends.

=head1 METHODS

=over 8

=item new $SERVER

Constructor. Expects to be passed the server to which to deploy.

=item createDBUnlessExists $NAME

Creates the DB with the given name, or skips it if it already exists. Returns true
if it did do something.

=item addDocumentUnlessExistsOrSame $ID, $DATA?, $ATTACH?

Creates the document with the given ID and optional data and attachments. If the
document exists it will do its best to find out if the version in the database is
the same as the current one (including attachments). If it is the same it will be
skipped, otherwise it will be updated. On creation it returns 1, on update 2, and
if nothing was done 0.

=item addDesignDocUnlessExistsOrSame $ID, $DATA

Creates the design doc with the given ID and data. On creation it returns 1,
on update 2, and if nothing was done 0.

=item getFile $PATH

Returns the content of the file in a form suitable for usage in CouchDB attachments.
Dies if it can't find the file.

=back

=head1 AUTHOR

Robin Berjon,

=head1 BUGS

Please report any bugs or feature requests to bug-couchdb-deploy at rt.cpan.org, or through the
web interface at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CouchDb-Deploy.

=head1 COPYRIGHT & LICENSE

Copyright 2008 Robin Berjon, all rights reserved.

This library is free software; you can redistribute it and/or modify it under the same terms as
Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may
have available.

=cut