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

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

Fixed a problem with delete_records()

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