The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;
use Test::More;
use Data::Dumper;

use CouchDB::Deploy;
use CouchDB::Client qw();

my $SERVER = $ARGV[0] || $ENV{COUCHDB_DEPLOY_SERVER} || 'http://localhost:5984/';
my $C = CouchDB::Client->new(uri => $SERVER);

if($C->testConnection) {
    plan tests => 31;
}
else {
    plan skip_all => 'Could not connect to CouchDB, skipping.';
    warn <<EOMSG;
You can specify how these tests can connect to CouchDB by setting the 
COUCHDB_CLIENT_URI environment variable to the address of your server.
EOMSG
    exit;
}


# CONFIG
my $dbName = 'test-perl-couchdb-deploy';
my $docName1 = 'dahut-is-coolness';
my $docName2 = 'higher-circle';
my $ddName1 = '_design/dahuts';
my $ddName2 = '_design/circles';

sub deploy {
    db $dbName, containing {
        doc {
            _id     => $docName1,
            type    => 'dahut',
            _attachments => {
                'foo.txt'   => {
                    content_type    => 'text/plain',
                    data            => 'RGFodXRzIEZvciBXb3JsZCBEb21pbmF0aW9uIQ==',
                },
                'bar.svg'   => {
                    content_type    => 'image/svg+xml',
                    data            => file 'dahut.svg',
                },
            },
        };
        design {
            _id         => $ddName1,
            language    => 'javascript',
            views   => {
                'all'   => {
                    map     => "function(doc) { if (doc.type == 'dahut')  emit(null, doc) }",
                },
            },
        };
    };
}

### --- FIRST CALL
eval { deploy(); };
ok not($@), 'deploy did not explode';

ok $C->dbExists($dbName), 'DB was created';
my $DB = $C->newDB($dbName);

ok @{$DB->listDocs} == 2, 'DB contains two docs (the doc and the design doc)';
ok $DB->docExists($docName1), 'DB contains the right doc name';
my $DOC = $DB->newDoc($docName1)->retrieve;
ok $DOC->data->{type} eq 'dahut', 'Good doc content';
ok keys %{$DOC->attachments} == 2, 'Good number of attachments';
ok $DOC->fetchAttachment('foo.txt') eq 'Dahuts For World Domination!', 'Attach 1 good content';
ok $DOC->fetchAttachment('bar.svg') =~ m/svg/, 'Attach 2 good content';

ok @{$DB->listDesignDocs} == 1, 'DB contains one design doc';
ok $DB->designDocExists($ddName1), 'DB contains the right design doc name';
my $DD = $DB->newDesignDoc($ddName1)->retrieve;
ok $DD->views->{all}, 'Good design doc content';

### --- SECOND CALL

my $docRev = $DOC->rev;
my $ddRev = $DD->rev;
eval { deploy(); };
ok not($@), 'deploy did not explode the second time';
ok $C->dbExists($dbName), 'DB still there';
ok @{$DB->listDocs} == 2, 'DB still contains two docs';
ok $DB->docExists($docName1), 'DB still contains the right doc name';
ok @{$DB->listDesignDocs} == 1, 'DB still contains one design doc';
ok $DB->designDocExists($ddName1), 'DB still contains the right design doc name';
$DOC->retrieve;
$DD->retrieve;
ok $docRev == $DOC->rev, 'Doc rev has not changed';
ok $ddRev == $DD->rev, 'Design Doc rev has not changed';


### --- EXTRA DOC AND DESIGN

eval {
    db $dbName, containing {
        doc {
            _id     => $docName2,
            type    => 'dahut',
        };
        design {
            _id         => $ddName2,
            language    => 'javascript',
            views   => {},
        };
    };
};
ok not($@), 'deploy of more did not explode';

ok $C->dbExists($dbName), 'DB still still there';
ok @{$DB->listDocs} == 4, 'DB now contains four docs';
ok $DB->docExists($docName2), 'DB contains new doc';
ok @{$DB->listDesignDocs} == 2, 'DB now contains two design doc';
ok $DB->designDocExists($ddName2), 'DB contains new design doc';
$DOC->retrieve;
$DD->retrieve;
ok $docRev == $DOC->rev, 'Old Doc rev has not changed';
ok $ddRev == $DD->rev, 'Old Design Doc rev has not changed';


### --- update a bit
my $DOC2 = $DB->newDoc($docName2)->retrieve;
my $doc2Rev = $DOC2->rev;
eval {
    db $dbName, containing {
        doc {
            _id     => $docName2,
            type    => 'dahut',
            more    => 'see elsewhere',
        };
    };
};
ok not($@), 'deploy of more did not explode';
ok @{$DB->listDocs} == 4, 'DB still contains four docs';
ok $DB->docExists($docName2), 'DB contains doc 2';
$DOC2->retrieve;
ok $doc2Rev != $DOC2->rev, 'Doc rev has changed';



### --- THE CLEANUP AT THE END

eval {
    $DD->delete;
    $DOC->delete;
    $DB->delete;
};
warn "\n\nSmall cleanup problem: $@\n\n" if $@;