File Coverage

blib/lib/MongoDBx/Tiny/Document.pm

Criterion	Covered	Total	%
statement	71	274	25.9
branch	1	78	1.2
condition	1	23	4.3
subroutine	22	56	39.2
pod	14	21	66.6
total	109	452	24.1

package MongoDBx::Tiny::Document;

use 5.006;
use strict;
use warnings;

=head1 NAME

MongoDBx::Tiny::Document - document class

=head1 SYNOPSIS

  package My::Data::Foo;
  use strict;
  use MongoDBx::Tiny::Document;

  COLLECTION_NAME 'foo';

  # FIELD NAME, sub{}, sub{}..
  ESSENTIAL q/code/; # like CDBI's Essential.
  FIELD 'code', INT, LENGTH(10), DEFAULT('0'), REQUIRED;
  FIELD 'name', STR, LENGTH(30), DEFAULT('noname');

  # RELATION ACCESSOR, sub{}
  RELATION 'bar', RELATION_DEFAULT('single','foo_id','id');

  INDEX 'code',{ unique => 1 };
  INDEX 'name';
  INDEX [code => 1, name => -1];

  sub process_some {
      my ($class,$tiny,$validator) = @_;
      $tiny->insert($class->collection_name,$validator->document);
  }


  package My::Data::Bar;
  use strict;
  use MongoDBx::Tiny::Document;

  COLLECTION_NAME 'bar';
  ESSENTIAL qw/foo_id code/;
  FIELD 'foo_id', OID, DEFAULT(''), REQUIRED;
  FIELD 'code',   INT(10),     DEFAULT('0'),REQUIRED;
  FIELD 'name',   VARCHAR(30), DEFAULT('noname'),&MY_ATTRIBUTE;

  RELATION 'foo', RELATION_DEFAULT('single','id','foo_id');

  TRIGGER  'before_insert', sub {
      my ($document_class,$tiny,$document,$opt) = @_;
  };

  # before_update,after_update,before_remove,after_remove
  TRIGGER  'after_insert', sub {
      my ($document_class,$object,$opt) = @_;
  };

  QUERY_ATTRIBUTES {
      # no support in update and delete
      single => { del_flag   => "off" },
      search => { del_flag   => "off" }
  };

  sub MY_ATTRIBUTE {
        return {
      	    name     => 'MY_ATTRIBUTE',
	    callback => sub {
                return 1;
	    }
        };
  }

=cut

use Data::Dumper;
use Scalar::Util qw(blessed);
use Class::Trigger;
use Carp qw/carp confess/;
use MongoDBx::Tiny::Util;
use Params::Validate;

use overload
    '""' => \&id,
    'fallback' => 1;

sub import {
    my $class = shift || __PACKAGE__;
    my $caller = (caller(0))[0];
    {
	no strict 'refs';
	push @{"${caller}::ISA"}, $class;
    }
    strict->import;
    warnings->import;
    __PACKAGE__->export_to_level(1, @_);
    if (__PACKAGE__ ne $class) {
	$class->export_to_level(1,@_);
    }
}

=head1 EXPORT

A list of functions that can be exported.

=head2 COLLECTION_NAME

  # define collection name.
  COLLECTION_NAME 'collection_name';

=head2 ESSENTIAL

  # define essential field always fetched.
  ESSENTIAL qw/field1 field2 field3/;

=head2 FIELD

  # define field name and validation.
  FIELD 'field_name', CODE, CODE;

=head2 RELATION

  RELATION 'relation_name', RELATION_NAME;

  sub RELATION_NAME {
      my $self   = shift;
      my $c_name = shift; # relation
      my $tiny = $self->tiny;
      # xxx
  }

=head2 TRIGGER

  [EXPERIMENTAL]

  TRIGGER  'phase', CODE;

=head2 QUERY_ATTRIBUTES

  [EXPERIMENTAL]

  QUERY_ATTRIBUTES {
      # no support in update and delete
      single => { del_flag   => "off" },
      search => { del_flag   => "off" }
  };

  TODO: no_query option for condition

=head2 INDEX

  [EXPERIMENTAL]

  INDEX 'field_1';
  INDEX 'field_2',{ unique => 1,drop_dups => 1, safe => 1, background => 1, name => 'foo' };
  INDEX [field_2 => 1, field_3 => -1];

  # for manage index
  $tiny->set_indexes('collection_name');

=head2 MongoDBx::Tiny::Attributes::EXPORT

  perldoc MongoDBx::Tiny::Attributes

=head2 MongoDBx::Tiny::Relation::EXPORT

  perldoc MongoDBx::Tiny::Relation

=cut


require Exporter;
our @ISA    = qw/Exporter/;
our @EXPORT = qw/COLLECTION_NAME ESSENTIAL FIELD RELATION TRIGGER QUERY_ATTRIBUTES INDEX/;
use MongoDBx::Tiny::Attributes;
use MongoDBx::Tiny::Relation;
push @EXPORT,@{MongoDBx::Tiny::Attributes::EXPORT};
push @EXPORT,@{MongoDBx::Tiny::Relation::EXPORT};

our $_COLLECTION_NAME;
our $_ESSENTIAL;
our $_FIELD;
our $_RELATION;

{
    no warnings qw(once);
    *COLLECTION_NAME  = \&install_collection_name;
    *ESSENTIAL        = \&install_essential;
    *FIELD            = \&install_field;
    *RELATION         = \&install_relation;
    *TRIGGER          = \&install_trigger;
    *QUERY_ATTRIBUTES = \&install_query_attributes;
    *INDEX            = \&install_index;
}

sub install_collection_name  { util_class_attr('COLLECTION_NAME',@_) }

sub install_essential{ util_class_attr('ESSENTIAL',@_)         }

sub install_field {
    my ($proto) = shift;
    my ($class,$stat) = util_guess_class($proto);
    my $name;
    if ($stat->{caller}) {
	$name = $proto;
    }


    my $attr = 'FIELD';

    my $field_obj  = util_class_attr($attr,$class) ||
	MongoDBx::Tiny::Document::Field->new;

    Carp::croak q/FIELD needs attributes/ unless @_;

    if (@_) {
	my (@type) = @_;
	$field_obj->add($name,\@type);
	util_class_attr($attr,$class,$field_obj);

	unless ($class->can($name)) {
	    my $accessor = sub {
		my $self = shift;
		unless ($self->_completed){
		    my $essential = $self->essential;
		    if (!$essential->{$name}) {
			my @not_complete = grep { !$essential->{$_}} $self->field->list;
			my $doc = $self->collection->find_one(
			    {_id => $self->id},{ map { $_ => 1 } @not_complete }
			);
			for (@not_complete) {
			    $self->{$_} = $doc->{$_};
			}
			$self->_completed(1);
		    }
		}

		if(@_ >= 1) {
		    $self->_changed($name);
		}
		if(@_ == 1) {
		    return $self->{$name} = $_[0];
		} elsif(@_ > 1) {
		    return $self->{$name} = [@_];
		} else {
		    return $self->{$name};
		}
	    };
	    {
		no strict 'refs';
		*{"${class}::${name}"} = $accessor;
	    }
	}
    }
    return $field_obj;
}

sub install_relation {
    my $proto = shift;

    my ($class,$stat) = util_guess_class($proto);

    my $c_name;
    if ($stat->{caller}) {
	$c_name = $proto;
    } else {
	$c_name = shift;
    }

    my $attr = 'RELATION';

    my $relation  = util_class_attr($attr,$class) ||
	MongoDBx::Tiny::Document::Relation->new;
    if (@_) {
	my ($clause) = @_;
	$relation->add($c_name => [$clause]);
	util_class_attr($attr,$class,$relation);

	unless ($class->can($c_name)) {
	    {
		no strict 'refs';
		*{$class . "::" . $c_name} = sub {
		    my $self = shift;
		    $clause->($self,$c_name);
		}
	    }
	}
    }
    return $relation;
}

sub install_trigger {
    my ($proto) = shift;
    my ($class,$stat) = util_guess_class($proto);
    my $name;
    if ($stat->{caller}) {
	$name = $proto;
    }
    if(@_) {
	my $trigger  = util_class_attr('TRIGGER',$class);
	$trigger->{$name} ++;
	util_class_attr('TRIGGER',$class,$trigger);
    }
    return $class->add_trigger($name,@_);
}

sub install_query_attributes{ util_class_attr('QUERY_ATTRIBUTES',@_)         }

sub install_index {
    my ($proto)       = shift;
    my ($class,$stat) = util_guess_class($proto);
    my $name;
    if ($stat->{caller}) {
	$name = $proto;
    }

    my $tmp;
    if ($name) {
	my ($index_opt,$opt) = @_;
	$tmp = util_class_attr('INDEXES') || [];
	push @$tmp,[ $name,$index_opt,$opt];
    }

    util_class_attr('INDEXES',$tmp);

}

=head1 SUBROUTINES/METHODS

=head2 new

  $document_object = $document_class->new($document,$tiny);

=cut

sub new {
    my $class    = shift;
    my $document = shift or confess q/no document/;
    my $tiny     = shift or confess q/no tiny/;
    my $self = bless $document , $class;
    $self->{_tiny}     = $tiny;
    $self->{_changed}    = {}; # field is changed or not
    $self->{_completed}  = 0;  # all fields are fetched or not.
    return $self;
}

sub _changed {
    my $self = shift;
    my $field  = shift;
    $self->{_changed}->{$field} = 1 if $field;
    return $self->{_changed};
}

sub _completed {
    my $self = shift;
    my $field  = shift;
    $self->{_completed} = 1 if $field;
    return $self->{_completed};
}

=head2 collection_name, essential, field, relation, trigger, query_attributes, indexes

  alias to installed value

    $collection_name = $document_object->collection_name;
    $essential       = $document_object->essential;# {_id => 1, field1 => 1, field2 => 1}

    # MongoDBx::Tiny::Document::Field
    $field      = $document_object->field;

    # MongoDBx::Tiny::Document::Relation
    $relation = $document_object->relation;

    $qa = $document_object->query_attributes;
    $attr = $qa->{$condition}; # condition: single,search

    $indexes = $document_object->indexes; # arrayref

=cut

sub collection_name  {
    my $class = shift; # or self
    util_class_attr('COLLECTION_NAME',$class);
}

sub essential {
    my $self = shift;
    my @essential = util_class_attr('ESSENTIAL',$self) || '_id';

    if (ref $essential[0] eq 'ARRAY') {
	@essential = @{$essential[0]};
    }
    my $ret = @essential ? { map { $_ => 1 } @essential } : {};
    $ret->{_id} = 1 unless $ret->{_id};
    return $ret;
}

sub field {
    my $class    = shift; # or self
    return util_class_attr('FIELD',$class);
}

sub relation {
    my $class = shift; # or self
    return util_class_attr('RELATION',$class);
}

sub trigger {
    my $class = shift; # or self
    my $name  = shift;
    my $stat  = util_class_attr('TRIGGER',$class);
    return $stat->{$name} if $name;
    return util_class_attr('TRIGGER',$class);
}

sub query_attributes  {
    my $class     = shift; # or self
    my $condition = shift;
    my $reserved = util_class_attr('QUERY_ATTRIBUTES',$class);

    return unless $reserved;
    return $reserved->{$condition} if $condition;
    return $reserved;
}

sub indexes {
    my $class = shift;
    util_class_attr('INDEXES',$class)
}

=head2 id

  returns document value "_id"

=cut

{
    no warnings qw(once);
    *id = \&_id;
}

sub _id   { shift->{_id} }

=head2 tiny

  returns MongoDBx::Tiny object

=cut

sub tiny {
    my $self = shift;
    my $tiny = $self->{_tiny};
    unless ($tiny->connection) {
	$tiny->connect;
    }
    return $tiny;
}

=head2 attributes_hashref

  alias to object_to_document

=cut

sub attributes_hashref { shift->object_to_document(@_) }

=head2 object_to_document

  $document = $document_object->object_to_document;

=cut

sub object_to_document {
    # xxx
    my $self = shift;
    my $opt  = shift;
    my $ret  = {};

    for my $field ("_id",$self->field->list) {
	$ret->{$field} = $self->$field();
    }
    return $ret;
}

=head2 collection

  returns MongoDB::Collection

    $collection = $document_object->collection('collection_name');

=cut

sub collection {
    my $self = shift;
    return $self->tiny->collection($self->collection_name);
}

=head2 update


  $document_object->field_name('val');
  $document_object->update;

  #
  $document_object->update($document);

  # only field_name will be changed
  $document_object->update({ field_name => 'val'});

=cut

sub update {
    my $self     = shift;
    my $document = shift;
    my $opt      = shift;
    $opt->{state} = 'update';
    if ($document && ! ref $document eq 'HASH') {
	confess 'invalid document';
    }

    for (keys %{$self->_changed}) {
	$document->{$_} = $self->$_();
    }

    if (!$document) {
	return;
    } else {
	return  unless (keys %$document);
    }

    my $validator = $self->tiny->validate(
	$self->collection_name,$document,$opt
    );

    if ($validator->has_error) {
	confess "invalid document: \n" . (Dumper $validator->errors);
    }
    unless ($opt->{no_trigger}) {
	$self->call_trigger('before_update',$opt);
    }

    $self->collection->update(
	{'_id' => $self->id},{ '$set' => $document }
    );
    $self->$_($document->{$_}) for keys %$document;
    $self->{_changed} = {};

    unless ($opt->{no_trigger}) {
	$self->call_trigger('after_update',$opt);
    }

    return $self;
}

=head2 remove

  $document_object->remove;

=cut

sub remove {
    my $self = shift;
    my $opt  = shift || {};

    unless ($opt->{no_trigger}) {
	$self->call_trigger('before_remove', $opt);
    }

    my $collection = $self->collection;
    $collection->remove({'_id' => $self->id});

    unless ($opt->{no_trigger}) {
	$self->call_trigger('after_remove', $opt);
    }

    bless $self, __PACKAGE__ . '::REMOVED';

    return 1;
}

sub DESTROY {
    # xxx
}

package MongoDBx::Tiny::Document::Accessor;
use strict;
use overload
    '""' => \&data,
    'fallback' => 1;

sub new {
    my $class = shift;
    my $field_info = shift || {}; # { field1 => [sub,sub], field2 => [sub,sub] }
    bless { _data => $field_info }, $class;
}

sub add {
    my $self = shift;
    my ($name,$val) = @_;
    $self->{_data}->{$name} = $val;
}

sub data {
    my $self = shift;
    return $self->{_data};
}

sub list {
    my $self = shift;
    keys %{$self->{_data}};
}

sub get {
    my $self = shift;
    my $name = shift;
    $self->{_data}->{$name};
}

=head2 MongoDBx::Tiny::Document::Field

    my $field = $document_object->field;

    my $attr  = $document_object->get('field_name');
    $attr->{name};
    $attr->{callback};

    my @field_names     = $field->list;

    my @default_fields  = $field->list('DEFAULT');
    my @required_fields = $field->list('REQUIRED')
    my @oid_fields      = $field->list('OID');

=cut

package MongoDBx::Tiny::Document::Field;
use base qw(MongoDBx::Tiny::Document::Accessor);

sub add {
    my $self = shift;
    my ($name,$val) = @_;
    for (@{$val}) {
	# { name => 'name', callback => sub{} }
	unless (defined $_->{name} ) {
	    die q/invalid field attribute: no name/;
	}
	unless (ref $_->{callback} eq 'CODE') {
	    die q/invalid field attribute: invalid callback: / . $_->{name};
	}

	my $req = $self->{_GROUP}->{$_->{name}} || [];
	push @$req, $name;
	$self->{_GROUP}->{$_->{name}} = $req;
    }
    $self->SUPER::add($name,$val);
}

sub list {
    my $self = shift;
    my $name = shift;
    if ($name) {
	my $req = $self->{_GROUP}->{$name} || [];
	return @$req;
    }
    $self->SUPER::list;
}

=head2 MongoDBx::Tiny::Document::Relation;

    my $relation  = $document_object->relation;
    my @relations = $relation->list;

=cut

package MongoDBx::Tiny::Document::Relation;
use base qw(MongoDBx::Tiny::Document::Accessor);

1;
__END__

=head1 AUTHOR

Naoto ISHIKAWA, C<< <toona at seesaa.co.jp> >>

=head1 LICENSE AND COPYRIGHT

Copyright 2013 Naoto ISHIKAWA.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut