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

Revision 0faedb747c77b2da4f5aa97abc381a4984c861a7, 6.1 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::Database;
2
3our $VERSION = '0.01';
4
5use Class::Inspector;
6use XAS::Model::Schema;
7use Params::Validate qw/SCALAR ARRAYREF/;
8
9use XAS::Class
10  debug      => 0,
11  version    => $VERSION,
12  base       => 'XAS::Base',
13  constants  => 'DELIMITER PKG REFS ARRAY',
14  filesystem => 'File',
15  exports => {
16    hooks => {
17      schema => [ \&_schema, 1 ],
18      table  => [ \&_tables, 1 ],
19      tables => [ \&_tables, 1 ],
20    }
21  },
22;
23
24our $KEYS;
25 
26#use Data::Dumper;
27
28# ---------------------------------------------------------------------
29# Hooks
30# ---------------------------------------------------------------------
31
32sub _tables {
33    my $self   = shift;
34    my $target = shift;
35    my $symbol = shift;
36    my $tables = shift;
37
38    $self->tables($tables, 4);
39
40    return $self;
41
42}
43
44sub _schema {
45    my $self    = shift;
46    my $target  = shift;
47    my $symbol  = shift;
48    my $schemas = shift;
49
50    $self->schemas($schemas);
51
52    return $self;
53
54}
55
56# ---------------------------------------------------------------------
57# Public Methods
58# ---------------------------------------------------------------------
59
60sub table {
61    my $self = shift;
62
63    $self->tables(@_);
64
65}
66
67sub tables {
68    my $self = shift;
69    my ($tables, $depth) = $self->validate_params(\@_, [
70        { type     => SCALAR | ARRAYREF },
71        { optional => 1, default => 3 },
72    ]);
73
74    $tables = [ split(DELIMITER, $tables) ] unless (ref($tables) eq ARRAY);
75
76    my ($pkg) = caller($depth);     # presummed caller
77
78    no strict REFS;                 # to register new methods in package
79    no warnings;                    # turn off warnings
80
81    foreach my $table (@$tables) {
82
83        # building constants in the calling package.
84
85        if ($table ne ':all') {
86
87            *{$pkg.PKG.$table} = sub { $KEYS->{$table}; };
88
89        } else {
90
91            while (my ($key, $value) = each(%$KEYS)) {
92
93                *{$pkg.PKG.$key} = sub { $value; };
94
95            }
96
97            last;
98
99        }
100
101    }
102
103}
104
105sub schemas {
106    my $self = shift;
107    my ($schemas) = $self->validate_params(\@_, [
108        { type => SCALAR | ARRAYREF },
109    ]);
110
111    $schemas = [ split(DELIMITER, $schemas) ] unless (ref($schemas) eq ARRAY);
112
113    foreach my $schema (@$schemas) {
114
115        # loading our schema
116
117        XAS::Model::Schema->load_namespaces(
118            result_namespace    => "+$schema" . "::Result",
119            resultset_namespace => "+$schema" . "::ResultSet",
120        );
121
122        # building our keys
123
124        my $pattern = $schema . '::';
125        my $modules = Class::Inspector->subclasses('UNIVERSAL');
126
127        foreach my $module (@$modules) {
128
129            next if ($module =~ /ResultSet/);
130
131            if ($module =~ m/$pattern/) {
132
133                my @parts = split('::', $module);
134                my $begin = scalar(@parts) - 1;
135                my $name = join('', splice(@parts, $begin, $#parts));
136
137                $KEYS->{$name} = $module;
138
139            }
140
141        }
142
143    }
144
145}
146
147# ---------------------------------------------------------------------
148# Private Methods
149# ---------------------------------------------------------------------
150
1511;
152
153__END__
154
155=head1 NAME
156
157XAS::Model::Database - A class to load database schemas
158
159=head1 SYNOPSIS
160
161  use XAS::Model::Schema;
162  use XAS::Model::Database
163    schema => 'ETL::Model::Database',
164    table  => 'Master';
165
166  try {
167
168      $schema = XAS::Model::Schema->opendb('database');
169
170      my @rows = Master->search($schema);
171
172      foreach my $row (@rows) {
173
174          printf("Hostname = %s\n", $row->Hostname);
175
176      }
177
178  } catch {
179
180      my $ex = $_;
181
182      print $ex;
183
184  };
185
186=head1 DESCRIPTION
187
188This module loads DBIx::Class table definations and defines a path for
189the database.ini configuration file. It can also load shortcut constants
190for table definations.
191
192Example
193
194    use XAS::Model::Database
195      schema => 'ETL::Model::Database',
196      table  => 'Master'
197    ;
198
199    or
200
201    use XAS::Model::Database
202      schema => 'ETL::Model::Database',
203      tables => qw( Master Detail )
204    ;
205
206    or
207
208    use XAS::Model::Database
209      schema => 'ETL::Model::Database',
210      table => ':all'
211    ;
212
213The difference is that in the first example you are only loading the
214"Master" constant into your module. The second example loads the constants
215"Master" and "Detail". The ":all" qualifer would load all the defined
216constants.
217
218=head1 HOOKS
219
220The following hooks are defined to load table definations and define
221constants. The order that they are called is important, i.e. 'schema' must
222come before 'table'.
223
224=head2 schema
225
226This defines a load path to the modules that defines a database schema.
227DBIx::Class loads modules based on the path. For example all modules
228below 'ETL::Model::Database' will be loaded at once. You can be more
229specific. If you only want the 'Progress' database schema you can load
230it by using 'ETL::Model::Database::Progress'.
231 
232=head2 table
233
234This will define a constant for a table defination. This constant is based
235on the table name, which is defined by the modules name. So the module
236'ETL::Model::Database::Progress::ActOther' will have a constant named
237'ActOther' that refers to the module.
238
239=over 4
240
241=item Warning
242
243If you have multiple tables named the same thing in differant schemas
244and load all the schemas at once, this constant will refer to the last
245loaded table defination.
246
247=back
248
249=head2 tables
250
251Does the same thing as 'table'.
252
253=head1 METHODS
254
255=head2 opendb($database)
256
257This method provides the defaults necessary to call the DBIx::Class::Schema
258connect() method. It takes one parameter.
259
260=over 4
261
262=item B<$database>
263
264The name of a configuration item suitable for DBIx::Class::Schema::Configure.
265
266Example
267
268    my $handle = XAS::Model::Database->opendb('database');
269
270=back
271
272=head1 SEE ALSO
273
274=over 4
275
276=item L<https://metacpan.org/pod/DBIx::Class|DBIx::Class>
277
278=item L<XAS|XAS>
279
280=back
281
282=head1 AUTHOR
283
284Kevin L. Esteb, E<lt>kevin@kesteb.usE<gt>
285
286=head1 COPYRIGHT AND LICENSE
287
288Copyright (C) 2014 Kevin L. Esteb
289
290This library is free software; you can redistribute it and/or modify
291it under the same terms as Perl itself, either Perl version 5.8.8 or,
292at your option, any later version of Perl 5 you may have available.
293
294See L<http://dev.perl.org/licenses/> for more information.
295
296=cut
Note: See TracBrowser for help on using the repository browser.