source: xas-model/trunk/lib/XAS/Model/DBM.pm @ fc5d23c129b6246a6eb88d5f78fdde934718e237

Revision fc5d23c129b6246a6eb88d5f78fdde934718e237, 12.8 KB checked in by Kevin L. Esteb <kevin@…>, 6 years ago (diff)

Initial load

  • Property mode set to 100644
Line 
1package XAS::Model::DBM;
2
3our $VERSION = '0.01';
4
5use XAS::Class
6  debug   => 0,
7  version => $VERSION,
8  base    => 'XAS::Base',
9  mixins  => 'create find search search_like find_or_create update_or_create
10              update_or_new count populate read_record create_record
11              delete_record update_record load_records',
12;
13
14# ---------------------------------------------------------------------
15# Database usability mixin functions
16# ---------------------------------------------------------------------
17
18sub create {
19    my $class  = shift;
20    my $schema = shift;
21
22    return $schema->resultset( $class->table_name )->create( @_ );
23
24}
25
26sub find {
27    my $class  = shift;
28    my $schema = shift;
29
30    return $schema->resultset( $class->table_name )->find( @_ );
31
32}
33
34sub search {
35    my $class  = shift;
36    my $schema = shift;
37
38    return $schema->resultset( $class->table_name )->search( @_ );
39
40}
41
42sub search_like {
43    my $class  = shift;
44    my $schema = shift;
45
46    return $schema->resultset( $class->table_name )->search_like( @_ );
47
48}
49
50sub find_or_create {
51    my $class  = shift;
52    my $schema = shift;
53
54    return $schema->resultset( $class->table_name )->find_or_create( @_ );
55
56}
57
58sub update_or_create {
59    my $class  = shift;
60    my $schema = shift;
61
62    return $schema->resultset( $class->table_name )->update_or_create( @_ );
63
64}
65
66sub update_or_new {
67    my $class  = shift;
68    my $schema = shift;
69
70    return $schema->resultset( $class->table_name )->update_or_new( @_ );
71
72}
73
74sub count {
75    my $class  = shift;
76    my $schema = shift;
77
78    return $schema->resultset( $class->table_name )->count( @_ );
79
80}
81
82sub populate {
83    my $class  = shift;
84    my $schema = shift;
85
86    return $schema->resultset( $class->table_name )->populate( @_ );
87
88}
89
90sub load_records {
91    my $class    = shift;
92    my $schema   = shift;
93
94    my @datum;
95    my @columns = $class->columns;
96
97    # find the records
98
99    if (my $rs = $class->search($schema, @_ )) {
100
101        # transfer the data
102
103        while (my $row = $rs->next) {
104
105            my $data;
106
107            foreach my $column (@columns) {
108
109                my $info = $class->column_info($column);
110
111                if ($info->{data_type} =~ m/^(datetime | timestamp)/x ) {
112
113                    my $dt = '';
114
115                    if ($row->$column) {
116
117                        $dt = sprintf("%s", $row->$column);
118                        $dt =~ s/T/ /;
119
120                    }
121
122                    $data->{$column} = $dt;
123
124                } else {
125
126                    $data->{$column} = $row->$column;
127
128                }
129
130            }
131
132            push(@datum, $data);
133
134        }
135
136    }
137
138    return \@datum;
139
140}
141
142sub read_record {
143    my $class    = shift;
144    my $schema   = shift;
145
146    my $data = undef;
147    my @columns = $class->columns;
148
149    # find the record
150
151    if (my $row = $class->find($schema, @_ )) {
152
153        # transfer the data
154
155        foreach my $column (@columns) {
156
157            my $info = $class->column_info($column);
158
159            if ($info->{data_type} =~ m/^(datetime | timestamp)/x ) {
160
161                my $dt = '';
162
163                if ($row->$column) {
164
165                    $dt = sprintf("%s", $row->$column);
166                    $dt =~ s/T/ /;
167
168                }
169
170                $data->{$column} = $dt;
171
172            } else {
173
174                $data->{$column} = $row->$column;
175
176            }
177
178        }
179
180    }
181
182    return $data;
183
184}
185
186sub create_record {
187    my $class  = shift;
188    my $schema = shift;
189    my $record = shift;
190
191    my $rec = undef;
192    my $data = undef;
193    my @columns = $class->columns;
194
195    # transfer and filter the data
196
197    $schema->txn_do(sub {
198
199        foreach my $column (@columns) {
200
201            my $info = $class->column_info($column);
202
203            if (defined($record->{$column})) {
204
205                next if ((defined($info->{auto_nextval}) ||
206                         (defined($info->{is_auto_increment}))));
207
208                $data->{$column} = $record->{$column};
209
210            }
211
212        }
213
214        # create the record
215
216        $class->create($schema, $data);
217
218        while (my ($key, $value) = each(%$record)) {
219
220            $rec->{$key} = $value;
221
222        }
223
224    });
225
226    return $rec;
227
228}
229
230sub delete_record {
231    my $class  = shift;
232    my $schema = shift;
233    my $record = shift;
234
235    my $data = undef;
236    my $criteria = {
237        id => $record->{id}
238    };
239
240    $schema->txn_do(sub { 
241
242        if (my $row = $class->find($schema, $criteria)) {
243
244            $row->delete();
245
246            while (my ($key, $value) = each(%$record)) {
247
248                $data->{$key} = $value;
249
250            }
251
252        }
253
254    });
255
256    return $data;
257
258}
259
260sub update_record {
261    my $class  = shift;
262    my $schema = shift;
263    my $record = shift;
264
265    my $data = undef;
266    my @columns = $class->columns;
267    my $criteria = {
268        id => $record->{id}
269    };
270
271    # retrieve the record
272
273    $schema->txn_do(sub {
274
275        if (my $row = $class->find($schema, $criteria)) {
276
277            # transfer the data
278
279            foreach my $column (@columns) {
280
281                my $info = $class->column_info($column);
282
283                if (defined($record->{$column})) {
284
285                    next if ((defined($info->{auto_nextval}) ||
286                             (defined($info->{is_auto_increment}))));
287
288                    $row->$column($record->{$column});
289
290                }
291
292            }
293
294            # update the record
295
296            $row->update();
297
298            while (my ($key, $value) = each(%$record)) {
299
300                $data->{$key} = $value;
301
302            }
303
304        }
305
306    });
307
308    return $data;
309
310}
311
3121;
313
314__END__
315
316=head1 NAME
317
318XAS::Model::DBM - Defines helper functions to DBIx::Class methods
319
320=head1 SYNOPSIS
321
322  use XAS::Model::DBM;
323
324=head1 DESCRIPTION
325
326This module is not usually included directly by user level code. It's
327primiary purpose is to be used as a mixin to a model. This module
328provides several shortcut methods that make database queries easier. To
329learn how they work, please consult the DBIx::Class documentation.
330
331You can use this methods in the following fashion.
332
333 use XAS::Model::Database 'Tablename';
334
335 my $schema = XAS::Model::Database->opendb();
336
337 ... DBIx::Class version
338
339 my @rows = $schema->resultset('Tablename')->search();
340
341 ... as compared to
342
343 my @rows = Tablename->search($schema);
344
345The shortcut require less typing and is slightly more intuitive. Neither
346approach is "more correct" then the other and sometimes they can be
347intermixed, especially when searching in related tables.
348
349=head1 METHODS
350
351=head2 create($class, $schema, ...)
352
353This method is a shortcut for creating records. It takes two or more
354parameters:
355
356=over 4
357
358=item B<$class>
359
360The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
361
362=item B<$schema>
363
364The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
365
366=item B<...>
367
368Other parameters that are passed directly to the DBIx::Class create() method.
369
370=back
371
372=head2 find($class, $schema, ...)
373
374This method is a shortcut for finding a single record. It takes two or more
375parameters:
376
377=over 4
378
379=item B<$class>
380
381The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
382
383=item B<$schema>
384
385The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
386
387=item B<...>
388
389Other parameters that are passed directly to the DBIx::Class find() method.
390
391=back
392
393=head2 search($class, $schena, ...)
394
395This method is a shortcut for record searches. It takes two or more
396parameters:
397
398=over 4
399
400=item B<$class>
401
402The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
403
404=item B<$schema>
405
406The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
407
408=item B<...>
409
410Other parameters that are passed directly to the DBIx::Class search() method.
411
412=back
413
414=head2 search_like($class, $schema, ...)
415
416This method is a shortcut for record searches. It takes two or more
417parameters:
418
419=over 4
420
421=item B<$class>
422
423The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
424
425=item B<$schema>
426
427The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
428
429=item B<...>
430
431Other parameters that are passed directly to the DBIx::Class search_like() method.
432
433=back
434
435=head2 count($class, $schema)
436
437This method is returns count of the record in a table. It takes two parameters:
438
439=over 4
440
441=item B<$class>
442
443The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
444
445=item B<$schema>
446
447The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
448
449=back
450
451=head2 find_or_create($class, $schema, ...)
452
453This method is a shortcut to find or create a record. It takes two or more
454parameters:
455
456=over 4
457
458=item B<$class>
459
460The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
461
462=item B<$schema>
463
464The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
465
466=item B<...>
467
468Other parameters that are passed directly to the DBIx::Class find_or_create()
469method.
470
471=back
472
473=head2 update_or_create($class, $schema, ...)
474
475This method is a shortcut for updating or creating a new record. It takes
476two or more parameters:
477
478=over 4
479
480=item B<$class>
481
482The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
483
484=item B<$schema>
485
486The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
487
488=item B<...>
489
490Other parameters that are passed directly to the DBIx::Class update_or_create()
491method.
492
493=back
494
495=head2 populate($class, $schena, ...)
496
497This method will load a hash of records into a table. It takes two or more
498parameters:
499
500=over 4
501
502=item B<$class>
503
504The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
505
506=item B<$schema>
507
508The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
509
510=item B<...>
511
512Other parameters that are passed directly to the DBIx::Class populate() method.
513
514=back
515
516=head2 load_records($class, $schema, ...)
517
518This method will load records into an array of hashes based on passed
519criteria. Any data conversion is done automatically. It takes two or
520more parameters:
521
522=over 4
523
524=item B<$class>
525
526The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
527
528=item B<$schema>
529
530The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
531
532=item B<...>
533
534Other parameters that are passed directly to the search() method.
535
536=back
537
538=head2 read_record($class, $schema, ...)
539
540This method will find a single record which is returned as a hash with
541any data conversion already done. It takes two or more parameters:
542
543=over 4
544
545=item B<$class>
546
547The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
548
549=item B<$schema>
550
551The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
552
553=item B<...>
554
555Other parameters that are passed directly to the find() method.
556
557=back
558
559=head2 create_record($class, $schema, $record)
560
561This method will create a single record from a hash. This is done within
562a transaction and any data conversion is done automatically. Only hash
563items that match actual fields within the table are stored. It returns a hash
564of the inserted fields. It takes three parameters:
565
566=over 4
567
568=item B<$class>
569
570The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
571
572=item B<$schema>
573
574The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
575
576=item B<$record>
577
578The record used to create the table entry.
579
580=back
581
582=head2 delete_record($class, $schema, $record)
583
584This method will delete a single record from the database. This is done
585within a transaction. It returns a hash of the record deleted. It takes
586three parameters:
587
588=over 4
589
590=item B<$class>
591
592The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
593
594=item B<$schema>
595
596The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
597
598=item B<$record>
599
600The record used to delete the table entry.
601
602=back
603
604=head2 update_record($class, $schema, $record)
605
606This method will update a single record in the database. This is done within a
607transaction. Only hash items that match actual fields within the table are
608updated. It returns a hash of the updated fields. It takes three parameters:
609
610=over 4
611
612=item B<$class>
613
614The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
615
616=item B<$schema>
617
618The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
619
620=item B<$record>
621
622The record used to update the table entry.
623
624=back
625
626=head1 SEE ALSO
627
628=over 4
629
630=item <https://metacpan.org/pod/DBIx::Class|DBIx::Class>
631
632=item L<XAS|XAS>
633
634=back
635
636=head1 AUTHOR
637
638Kevin L. Esteb, E<lt>kevin@kesteb.usE<gt>
639
640=head1 COPYRIGHT AND LICENSE
641
642Copyright (C) 2014 Kevin L. Esteb
643
644This library is free software; you can redistribute it and/or modify
645it under the same terms as Perl itself, either Perl version 5.8.8 or,
646at your option, any later version of Perl 5 you may have available.
647
648See L<http://dev.perl.org/licenses/> for more information.
649
650=cut
Note: See TracBrowser for help on using the repository browser.