view release on metacpan or  search on metacpan

examples/test-validate-json-body/app/lib/Dwarf/Module/DSL.pm  view on Meta::CPAN

package Dwarf::Module::DSL;
use Dwarf::Pragma;
use Dwarf::Util qw/load_class dwarf_log/;
use Carp qw/croak/;
use Data::Validator;
use Scalar::Util qw/weaken/;

use Dwarf::Accessor {
	ro => [qw/context module/],
	rw => [qw/prefix/]
};

our @FUNC = qw/
	self app c model m
	conf db error e env log debug
	session param parameters
	request req method
	response res status type header headers body
	not_found unauthorized finish redirect
	is_cli is_production
	load_plugin load_plugins
	render dump args
/;

sub new {
	my $class = shift;
	my $self = bless { @_ }, $class;
	dwarf_log 'new DSL';
	return $self;
}

sub DESTROY {
	my $self = shift;
	dwarf_log 'DESTROY DSL';
}

sub init {}

sub _build_prefix  {
	my $self = shift;
	$self->{prefix} ||= $self->c->namespace . '::Model';
}

sub app           { shift->context }
sub c             { shift->context }
sub m             { shift->model(@_) }
sub conf          { shift->c->conf(@_) }
sub db            { shift->c->db(@_) }
sub error         { shift->c->error(@_) }
sub e             { shift->c->error(@_) }
sub env           { shift->c->env }
sub log           { shift->c->log(@_) }
sub debug         { shift->c->debug(@_) }

sub session       { shift->c->session(@_) }
sub param         { shift->c->request->param(@_) }
sub parameters    { shift->c->request->parameters(@_) }
sub request       { shift->c->request(@_) }
sub req           { shift->c->request(@_) }
sub method        { shift->c->method(@_) }
sub response      { shift->c->response(@_) }
sub res           { shift->c->response(@_) }
sub status        { shift->c->status(@_) }
sub type          { shift->c->type(@_) }
sub header        { shift->c->header(@_) }
sub headers       { shift->c->headers(@_) }

examples/test-validate-json-body/app/lib/Dwarf/Module/DSL.pm  view on Meta::CPAN

		$rules->{$key} = $value;
	}

	my $validator = Data::Validator->new(%$rules)->with(qw/NoRestricted AllowExtra NoThrow/);
	my @ret = $validator->validate($args);

	if ($validator->has_errors) {
		my $errors = $validator->clear_errors;
		croak $self->handle_errors($rules, $module, $args, $errors);
	}
	
	return wantarray ? ($self, $ret[0]) : $ret[0];
}

sub handle_errors {
	my ($self, $rules, $module, $args, $errors) = @_;

	my @list;
	push @list, join "", map { $_->{message} } @$errors;
	push @list, '[Module] ' . ref($module);
	push @list, '[Rules] ' . $self->c->dump($rules);
	push @list, '[Args] ' . $self->c->dump($args);

	for my $i (0 .. 100) {
		my ($package, $filename, $line, $func) = caller($i);
		last unless $func;
		push @list, $func . " at line " . $line;
	}

	return join "\n", @list;
}

sub model {
	my $self = shift;
	my $package = shift;

	my $prefix = $self->prefix;
	unless ($package =~ m/^$prefix/) {
		$package = $prefix . '::' . $package;
	}

	$self->context->models->{$package} //= $self->create_model($package, @_);
}

sub create_model {
	my $self = shift;
	my $package = shift;

	croak "package name must be specified to create model."
		unless defined $package;

	my $prefix = $self->prefix;
	unless ($package =~ m/^$prefix/) {
		$package = $prefix . '::' . $package;
	}

	dwarf_log "create model: $package";

	load_class($package);
	my $model = $package->new(context => $self->context, @_);
	weaken $model->{context};
	$model->init($self->context);
	return $model;
}

sub export_symbols {
	my ($self, $to) = @_;

	no strict 'refs';
	no warnings 'redefine';
	my $super = *{"${to}::ISA"}{ARRAY};
	if ($super && $super->[0]) {
		$self->export_symbols($super->[0]);
	}

	for my $f (@FUNC) {
		*{"${to}::${f}"} = sub {
			# OO インターフェース　で呼ばれた時対策
			shift if defined $_[0] and $_[0] eq $self->module;
			return $self->module if $f eq 'self';
			$self->$f(@_)
		};
	}
}

sub delete_symbols {
	my ($self, $from) = @_;

	no strict 'refs';
	no warnings 'redefine';
	my $super = *{"${from}::ISA"}{ARRAY};
	if ($super && $super->[0]) {
		$self->delete_symbols($super->[0]);
	}

	for my $f (@FUNC) {
		*{"${from}::${f}"} = sub {};
	}
}

1;