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

CouchDB-Deploy documentation Contained in the CouchDB-Deploy distribution.

Index

Code Index:

NAME

Top

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

SYNOPSIS

Top

    use CouchDB::Deploy;
    ...

DESCRIPTION

Top

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.

METHODS

Top

new $SERVER

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

createDBUnlessExists $NAME

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

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.

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.

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.

AUTHOR

Top

Robin Berjon, <robin @t berjon d.t com>

BUGS

Top

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.

COPYRIGHT & LICENSE

Top

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.

CouchDB-Deploy documentation Contained in the CouchDB-Deploy distribution. 
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;