File Coverage

blib/lib/Yancy/Model.pm
Criterion Covered Total %
statement 101 108 93.5
branch 27 36 75.0
condition 13 17 76.4
subroutine 14 14 100.0
pod 6 6 100.0
total 161 181 88.9


line stmt bran cond sub pod time code
1             package Yancy::Model;
2             our $VERSION = '1.086';
3             # ABSTRACT: Model layer for Yancy apps
4              
5             #pod =head1 SYNOPSIS
6             #pod
7             #pod # XXX: Allow using backend strings
8             #pod my $model = Yancy::Model->new( backend => $backend );
9             #pod
10             #pod my $schema = $model->schema( 'foo' );
11             #pod
12             #pod my $id = $schema->create( $data );
13             #pod my $count = $schema->delete( $id );
14             #pod my $count = $schema->delete( $where );
15             #pod my $count = $schema->set( $id, $data );
16             #pod my $count = $schema->set( $where, $data );
17             #pod
18             #pod my $item = $schema->get( $id );
19             #pod my ( $items, $total ) = $schema->list( $where, $opts );
20             #pod for my $item ( @$items ) {
21             #pod }
22             #pod
23             #pod my $success = $row->set( $data );
24             #pod my $success = $row->delete();
25             #pod my $data = $row->to_hash;
26             #pod
27             #pod =head1 DESCRIPTION
28             #pod
29             #pod B: This module is experimental and its API may change before
30             #pod Yancy v2!
31             #pod
32             #pod L is a framework for your business logic. L
33             #pod contains a number of schemas, L objects. Each
34             #pod schema contains a number of items, L objects.
35             #pod
36             #pod For information on how to extend this module to add your own schema
37             #pod and item methods, see L.
38             #pod
39             #pod =head1 SEE ALSO
40             #pod
41             #pod L
42             #pod
43             #pod =cut
44              
45 20     20   267697 use Mojo::Base -base;
  20         57  
  20         150  
46 20     20   3350 use Scalar::Util qw( blessed );
  20         61  
  20         1090  
47 20     20   118 use Mojo::Util qw( camelize );
  20         42  
  20         1070  
48 20     20   659 use Mojo::Loader qw( load_class );
  20         38755  
  20         1110  
49 20     20   775 use Mojo::Log;
  20         16066  
  20         162  
50 20     20   1296 use Yancy::Util qw( derp );
  20         64  
  20         1080  
51 20     20   147 use Storable qw( dclone );
  20         35  
  20         38416  
52              
53             #pod =attr backend
54             #pod
55             #pod A L object.
56             #pod
57             #pod =cut
58              
59             has backend => sub { die "backend is required" };
60              
61             #pod =attr namespaces
62             #pod
63             #pod An array of namespaces to find Schema and Item classes. Defaults to C<[ 'Yancy::Model' ]>.
64             #pod
65             #pod =cut
66              
67             has namespaces => sub { [qw( Yancy::Model )] };
68              
69             #pod =attr log
70             #pod
71             #pod A L object to log messages to.
72             #pod
73             #pod =cut
74              
75             has log => sub { Mojo::Log->new };
76              
77             has _schema => sub { {} };
78             has _config_schema => sub { {} };
79             has _auto_read => 1;
80              
81             #pod =method new
82             #pod
83             #pod Create a new model with the given backend. In addition to any L, these
84             #pod options may be given:
85             #pod
86             #pod =over
87             #pod
88             #pod =item schema
89             #pod
90             #pod A JSON schema configuration. By default, the information from
91             #pod L will be merged with this information. See
92             #pod L for more information.
93             #pod
94             #pod =item read_schema
95             #pod
96             #pod Read the backend database information to build the schema information.
97             #pod Enabled by default. Set to a false value to disable.
98             #pod
99             #pod =back
100             #pod
101             #pod =cut
102              
103             sub new {
104 106     106 1 3215 my ( $class, @args ) = @_;
105 106 50       675 my %args = @args == 1 ? %{ $args[0] } : @args;
  0         0  
106 106 100       567 my $conf = $args{_config_schema} = delete $args{schema} if $args{schema};
107 106 100       413 my $read = exists $args{read_schema} ? delete $args{read_schema} : 1;
108 106         264 $args{ _auto_read } = $read;
109 106         471 my $self = $class->SUPER::new(\%args);
110 106 100       1237 if ( $read ) {
    100          
111 92         343 $self->read_schema;
112             }
113 54         145 elsif ( my @names = grep { delete $conf->{$_}{read_schema} } keys %$conf ) {
114 1         10 $self->read_schema( @names );
115             }
116 106         575 return $self;
117             }
118              
119             #pod =method find_class
120             #pod
121             #pod Find a class of the given type for an object of the given name. The name is run
122             #pod through L before lookups.
123             #pod
124             #pod unshift @{ $model->namespaces }, 'MyApp';
125             #pod # MyApp::Schema::User
126             #pod $class = $model->find_class( Schema => 'user' );
127             #pod # MyApp::Item::UserProfile
128             #pod $class = $model->find_class( Item => 'user_profile' );
129             #pod
130             #pod If a specific class cannot be found, a generic class for the type is found instead.
131             #pod
132             #pod # MyApp::Schema
133             #pod $class = $model->find_class( Schema => 'not_found' );
134             #pod # MyApp::Item
135             #pod $class = $model->find_class( Item => 'not_found' );
136             #pod
137             #pod =cut
138              
139             sub find_class {
140 516     516 1 1225 my ( $self, $type, $name ) = @_;
141             # First, a specific class for this named type.
142 516         728 for my $namespace ( @{ $self->namespaces } ) {
  516         1380  
143 516         3521 my $class = "${namespace}::${type}::" . camelize( $name );
144 516 50       9880 if ( my $e = load_class $class ) {
145 516 50       151274 if ( ref $e ) {
146 0         0 die "Could not load $class: $e";
147             }
148             # Not found, try the next one
149 516         1462 next;
150             }
151             # No error, so this is the class we want
152 0         0 return $class;
153             }
154              
155             # Finally, try to find a generic type class
156 516         860 for my $namespace ( @{ $self->namespaces } ) {
  516         1647  
157 516         3298 my $class = "${namespace}::${type}";
158 516 50       1225 if ( my $e = load_class $class ) {
159 0 0       0 if ( ref $e ) {
160 0         0 die "Could not load $class: $e";
161             }
162             # Not found, try the next one
163 0         0 next;
164             }
165             # No error, so this is the class we want
166 516         8385 return $class;
167             }
168              
169 0         0 die "Could not find class for type $type or name $name";
170             }
171              
172             #pod =method read_schema
173             #pod
174             #pod Read the schema from the L and prepare schema objects using L
175             #pod to find the correct classes.
176             #pod
177             #pod =cut
178              
179             sub read_schema {
180 93     93 1 238 my ( $self, @names ) = @_;
181 93         318 my $conf_schema = $self->_config_schema;
182 93         473 my $read_schema;
183 93 100       285 if ( @names ) {
184 1         3 $read_schema = { map { $_ => $self->backend->read_schema( $_ ) } @names };
  1         5  
185             }
186             else {
187 92         331 $read_schema = $self->backend->read_schema( @names );
188 92         475 my %all_schemas = map { $_ => 1 } keys %$conf_schema, keys %$read_schema;
  917         1627  
189 92         510 @names = keys %all_schemas;
190             }
191              
192             # Make all concrete schemas first, then any views.
193             # XXX: x-view is deprecated. Remove the sort in v2.
194 93         555 @names = sort { !!$conf_schema->{$a}{'x-view'} <=> !!$conf_schema->{$b}{'x-view'} } @names;
  926         1809  
195              
196 93         251 for my $name ( @names ) {
197             # ; use Data::Dumper;
198             # ; say "Creating schema $name";
199             # ; say "Has view " . Dumper $conf_schema->{$name}{'x-view'} if $conf_schema->{$name}{'x-view'};
200 560   50     2737 my $full_schema = _merge_schema( $conf_schema->{ $name } // {}, $read_schema->{ $name } // {} );
      100        
201 560 100       1385 if ( $full_schema->{'x-ignore'} ) {
202             # Remember we're ignoring this schema
203 94         260 $conf_schema->{ $name }{ 'x-ignore' } = 1;
204 94         382 next;
205             }
206 466         1240 $self->schema( $name, $full_schema );
207             }
208 93         2623 return $self;
209             }
210              
211             #pod =method schema
212             #pod
213             #pod Get or set a schema object.
214             #pod
215             #pod $model = $model->schema( user => MyApp::Model::User->new );
216             #pod $schema = $model->schema( 'user' );
217             #pod
218             #pod =cut
219              
220             sub schema {
221 1977     1977 1 36935 my ( $self, $name, $data ) = @_;
222 1977 100       4351 if ( !$data ) {
223 1486 100       3734 if ( my $schema = $self->_schema->{ $name } ) {
224 1461         10524 return $schema;
225             }
226             # Create a default schema
227 25         132 my $conf = $self->_config_schema->{ $name };
228 25 50       131 die "Schema $name is ignored" if $conf->{'x-ignore'};
229 25         79 $self->schema( $name, $conf );
230 23         45 return $self->_schema->{ $name };
231             }
232 491 50 33     2083 if ( !blessed $data || !$data->isa( 'Yancy::Model::Schema' ) ) {
233 491         1101 my $class = $self->find_class( Schema => $name );
234 491         1693 $data = $class->new( model => $self, name => $name, json_schema => $data );
235             }
236 489         1265 $self->_schema->{$name} = $data;
237 489         2215 return $self;
238             }
239              
240             #pod =method json_schema
241             #pod
242             #pod Get the JSON Schema for every attached schema.
243             #pod
244             #pod =cut
245              
246             sub json_schema {
247 51     51 1 160 my ( $self, @names ) = @_;
248 51 50       238 if ( !@names ) {
249 51         180 @names = $self->schema_names;
250             }
251             return {
252 51         150 map { $_ => $self->schema( $_ )->json_schema } @names
  250         1039  
253             };
254             }
255              
256             #pod =method schema_names
257             #pod
258             #pod Get a list of all the schema names.
259             #pod
260             #pod =cut
261              
262             sub schema_names {
263 144     144 1 342 my ( $self ) = @_;
264 144         401 my $conf = $self->_config_schema;
265 144         905 my %all_schemas = map { $_ => 1 } grep !$conf->{$_}{'x-ignore'}, keys %$conf, keys %{ $self->_schema };
  1425         3565  
  144         358  
266 144         863 return keys %all_schemas;
267             }
268              
269             # _merge_schema( $keep, $merge );
270             #
271             # Merge the two schemas, returning the result.
272             sub _merge_schema {
273 560     560   1119 my ( $left, $right ) = @_;
274             # ; use Data::Dumper;
275             # ; say "Split schema " . Dumper( $left ) . Dumper( $right );
276 560         30114 my $keep = dclone $left;
277 560 100       2185 if ( my $right_props = $right->{properties} ) {
278 419   100     1228 my $keep_props = $keep->{properties} ||= {};
279 419         603 for my $p ( keys %{ $right_props } ) {
  419         1480  
280 2618   100     5812 my $keep_prop = $keep_props->{ $p } ||= {};
281 2618         3368 my $right_prop = $right_props->{ $p };
282 2618         5367 for my $k ( keys %$right_prop ) {
283 6742   100     16195 $keep_prop->{ $k } ||= $right_prop->{ $k };
284             }
285             }
286             }
287 560         1727 for my $k ( keys %$right ) {
288 1667 100       2889 next if $k eq 'properties';
289 1248   66     3000 $keep->{ $k } ||= $right->{ $k };
290             }
291             # ; use Data::Dumper;
292             # ; say "Merged schema " . Dumper $keep;
293 560         1190 return $keep;
294             }
295              
296             1;
297              
298             __END__