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

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

Fixed a logic problem and added a delete_records() method.

  • 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 delete_records {
143    my $class  = shift;
144    my $schema = shift;
145
146    $schema->txn_do(sub { 
147
148        if (my $rs = $class->search($schema, @_)) {
149
150            while (my $row = $rs->next) {
151
152                $row->delete();
153
154            }
155
156        }
157
158    });
159
160}
161
162sub read_record {
163    my $class    = shift;
164    my $schema   = shift;
165
166    my $data = undef;
167    my @columns = $class->columns;
168
169    # find the record
170
171    if (my $row = $class->find($schema, @_ )) {
172
173        # transfer the data
174
175        foreach my $column (@columns) {
176
177            my $info = $class->column_info($column);
178
179            if ($info->{data_type} =~ m/^(datetime | timestamp)/x ) {
180
181                my $dt = '';
182
183                if ($row->$column) {
184
185                    $dt = sprintf("%s", $row->$column);
186                    $dt =~ s/T/ /;
187
188                }
189
190                $data->{$column} = $dt;
191
192            } else {
193
194                $data->{$column} = $row->$column;
195
196            }
197
198        }
199
200    }
201
202    return $data;
203
204}
205
206sub create_record {
207    my $class  = shift;
208    my $schema = shift;
209    my $record = shift;
210
211    my $rec = undef;
212    my $data = undef;
213    my @columns = $class->columns;
214
215    # transfer and filter the data
216
217    $schema->txn_do(sub {
218
219        foreach my $column (@columns) {
220
221            my $info = $class->column_info($column);
222
223            if (defined($record->{$column})) {
224
225                next if ((defined($info->{auto_nextval}) ||
226                         (defined($info->{is_auto_increment}))));
227
228                $data->{$column} = $record->{$column};
229
230            }
231
232        }
233
234        # create the record
235
236        $class->create($schema, $data);
237
238        while (my ($key, $value) = each(%$record)) {
239
240            $rec->{$key} = $value;
241
242        }
243
244    });
245
246    return $rec;
247
248}
249
250sub delete_record {
251    my $class  = shift;
252    my $schema = shift;
253    my $record = shift;
254
255    my $data = undef;
256    my $criteria = {
257        id => $record->{id}
258    };
259
260    $schema->txn_do(sub { 
261
262        if (my $row = $class->find($schema, $criteria)) {
263
264            $row->delete();
265
266            while (my ($key, $value) = each(%$record)) {
267
268                $data->{$key} = $value;
269
270            }
271
272        }
273
274    });
275
276    return $data;
277
278}
279
280sub update_record {
281    my $class  = shift;
282    my $schema = shift;
283    my $record = shift;
284
285    my $data = undef;
286    my @columns = $class->columns;
287    my $criteria = {
288        id => $record->{id}
289    };
290
291    # retrieve the record
292
293    $schema->txn_do(sub {
294
295        if (my $row = $class->find($schema, $criteria)) {
296
297            # transfer the data
298
299            foreach my $column (@columns) {
300
301                my $info = $class->column_info($column);
302
303                if (defined($record->{$column})) {
304
305                    next if ((defined($info->{auto_nextval}) ||
306                             (defined($info->{is_auto_increment}))));
307
308                    $row->$column($record->{$column});
309
310                }
311
312            }
313
314            # update the record
315
316            $row->update();
317
318            while (my ($key, $value) = each(%$record)) {
319
320                $data->{$key} = $value;
321
322            }
323
324        }
325
326    });
327
328    return $data;
329
330}
331
3321;
333
334__END__
335
336=head1 NAME
337
338XAS::Model::DBM - Defines helper functions to DBIx::Class methods
339
340=head1 SYNOPSIS
341
342  use XAS::Model::DBM;
343
344=head1 DESCRIPTION
345
346This module is not usually included directly by user level code. It's
347primiary purpose is to be used as a mixin to a model. This module
348provides several shortcut methods that make database queries easier. To
349learn how they work, please consult the DBIx::Class documentation.
350
351You can use this methods in the following fashion.
352
353 use XAS::Model::Database 'Tablename';
354
355 my $schema = XAS::Model::Database->opendb();
356
357 ... DBIx::Class version
358
359 my @rows = $schema->resultset('Tablename')->search();
360
361 ... as compared to
362
363 my @rows = Tablename->search($schema);
364
365The shortcut require less typing and is slightly more intuitive. Neither
366approach is "more correct" then the other and sometimes they can be
367intermixed, especially when searching in related tables.
368
369=head1 METHODS
370
371=head2 create($class, $schema, ...)
372
373This method is a shortcut for creating records. It takes two or more
374parameters:
375
376=over 4
377
378=item B<$class>
379
380The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
381
382=item B<$schema>
383
384The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
385
386=item B<...>
387
388Other parameters that are passed directly to the DBIx::Class create() method.
389
390=back
391
392=head2 find($class, $schema, ...)
393
394This method is a shortcut for finding a single record. It takes two or more
395parameters:
396
397=over 4
398
399=item B<$class>
400
401The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
402
403=item B<$schema>
404
405The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
406
407=item B<...>
408
409Other parameters that are passed directly to the DBIx::Class find() method.
410
411=back
412
413=head2 search($class, $schena, ...)
414
415This method is a shortcut for record searches. It takes two or more
416parameters:
417
418=over 4
419
420=item B<$class>
421
422The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
423
424=item B<$schema>
425
426The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
427
428=item B<...>
429
430Other parameters that are passed directly to the DBIx::Class search() method.
431
432=back
433
434=head2 search_like($class, $schema, ...)
435
436This method is a shortcut for record searches. It takes two or more
437parameters:
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=item B<...>
450
451Other parameters that are passed directly to the DBIx::Class search_like() method.
452
453=back
454
455=head2 count($class, $schema)
456
457This method is returns count of the record in a table. It takes two parameters:
458
459=over 4
460
461=item B<$class>
462
463The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
464
465=item B<$schema>
466
467The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
468
469=back
470
471=head2 find_or_create($class, $schema, ...)
472
473This method is a shortcut to find or create a record. It takes two or more
474parameters:
475
476=over 4
477
478=item B<$class>
479
480The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
481
482=item B<$schema>
483
484The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
485
486=item B<...>
487
488Other parameters that are passed directly to the DBIx::Class find_or_create()
489method.
490
491=back
492
493=head2 update_or_create($class, $schema, ...)
494
495This method is a shortcut for updating or creating a new record. It takes
496two or more parameters:
497
498=over 4
499
500=item B<$class>
501
502The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
503
504=item B<$schema>
505
506The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
507
508=item B<...>
509
510Other parameters that are passed directly to the DBIx::Class update_or_create()
511method.
512
513=back
514
515=head2 populate($class, $schena, ...)
516
517This method will load a hash of records into a table. It takes two or more
518parameters:
519
520=over 4
521
522=item B<$class>
523
524The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
525
526=item B<$schema>
527
528The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
529
530=item B<...>
531
532Other parameters that are passed directly to the DBIx::Class populate() method.
533
534=back
535
536=head2 load_records($class, $schema, ...)
537
538This method will load records into an array of hashes based on passed
539criteria. Any data conversion is done automatically. It takes two or
540more parameters:
541
542=over 4
543
544=item B<$class>
545
546The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
547
548=item B<$schema>
549
550The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
551
552=item B<...>
553
554Other parameters that are passed directly to the search() method.
555
556=back
557
558=head2 delete_records($class, $schema, ...)
559
560This method will delete records based on the passed criteria.
561It takes two or more parameters:
562
563=over 4
564
565=item B<$class>
566
567The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
568
569=item B<$schema>
570
571The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
572
573=item B<...>
574
575Other parameters that are passed directly to the search() method.
576
577=back
578
579=head2 read_record($class, $schema, ...)
580
581This method will find a single record which is returned as a hash with
582any data conversion already done. It takes two or more parameters:
583
584=over 4
585
586=item B<$class>
587
588The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
589
590=item B<$schema>
591
592The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
593
594=item B<...>
595
596Other parameters that are passed directly to the find() method.
597
598=back
599
600=head2 create_record($class, $schema, $record)
601
602This method will create a single record from a hash. This is done within
603a transaction and any data conversion is done automatically. Only hash
604items that match actual fields within the table are stored. It returns a hash
605of the inserted fields. It takes three parameters:
606
607=over 4
608
609=item B<$class>
610
611The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
612
613=item B<$schema>
614
615The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
616
617=item B<$record>
618
619The record used to create the table entry.
620
621=back
622
623=head2 delete_record($class, $schema, $record)
624
625This method will delete a single record from the database. This is done
626within a transaction. It returns a hash of the record deleted. It takes
627three parameters:
628
629=over 4
630
631=item B<$class>
632
633The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
634
635=item B<$schema>
636
637The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
638
639=item B<$record>
640
641The record used to delete the table entry.
642
643=back
644
645=head2 update_record($class, $schema, $record)
646
647This method will update a single record in the database. This is done within a
648transaction. Only hash items that match actual fields within the table are
649updated. It returns a hash of the updated fields. It takes three parameters:
650
651=over 4
652
653=item B<$class>
654
655The DBIx::Class model name. Usually a constant defined within XAS::Model::Database.
656
657=item B<$schema>
658
659The DBIx::Class schema handle returned from opendb() in XAS::Model::Database.
660
661=item B<$record>
662
663The record used to update the table entry.
664
665=back
666
667=head1 SEE ALSO
668
669=over 4
670
671=item <https://metacpan.org/pod/DBIx::Class|DBIx::Class>
672
673=item L<XAS|XAS>
674
675=back
676
677=head1 AUTHOR
678
679Kevin L. Esteb, E<lt>kevin@kesteb.usE<gt>
680
681=head1 COPYRIGHT AND LICENSE
682
683Copyright (C) 2014 Kevin L. Esteb
684
685This library is free software; you can redistribute it and/or modify
686it under the same terms as Perl itself, either Perl version 5.8.8 or,
687at your option, any later version of Perl 5 you may have available.
688
689See L<http://dev.perl.org/licenses/> for more information.
690
691=cut
Note: See TracBrowser for help on using the repository browser.