File Coverage

lib/UR/Namespace/Command/Define/Datasource/Rdbms.pm
Criterion Covered Total %
statement 71 88 80.6
branch 12 20 60.0
condition 1 3 33.3
subroutine 12 15 80.0
pod 0 1 0.0
total 96 127 75.5


line stmt bran cond sub pod time code
1             package UR::Namespace::Command::Define::Datasource::Rdbms;
2              
3 2     2   33 use strict;
  2         2  
  2         47  
4 2     2   7 use warnings;
  2         2  
  2         37  
5 2     2   6 use UR;
  2         2  
  2         9  
6             our $VERSION = "0.46"; # UR $VERSION;
7              
8 2     2   6 use IO::File;
  2         2  
  2         1411  
9              
10             UR::Object::Type->define(
11             class_name => __PACKAGE__,
12             is => 'UR::Namespace::Command::Define::Datasource',
13             has => [
14             server => {
15             is => 'String',
16             doc => '"server" attribute for this data source, such as a database name',
17             is_optional => 1,
18             },
19             nosingleton => {
20             is => 'Boolean',
21             doc => 'Created data source should not inherit from UR::Singleton (defalt is that it will)',
22             default_value => 0,
23             },
24             ],
25             is_abstract => 1,
26             );
27              
28             sub help_description {
29 0     0 0 0 "Define a UR datasource connected to a relational database through UR::DataSource::RDBMS and DBI";
30             }
31              
32              
33             sub execute {
34 3     3   5 my $self = shift;
35              
36 3         9 my $namespace = $self->namespace_name;
37 3 50       11 unless ($namespace) {
38 0         0 $self->error_message("This command must be run from a namespace directory.");
39 0         0 return;
40             }
41              
42 3 50 33     12 unless ($self->__dsname || $self->__dsid) {
43 0         0 $self->error_message("Either --dsname or --dsid is required");
44 0         0 return;
45             }
46              
47             # Force an autoload of the namespace module
48             #my $ret = above::use_package($namespace);
49 3     1   250 eval "use $namespace";
  1     1   8  
  1     1   2  
  1         8  
  1         9  
  1         2  
  1         7  
  1         6  
  1         4  
  1         7  
50 3 50       14 if ($@) {
51 0         0 $self->error_message("Can't load namespace $namespace: $@");
52 0         0 return;
53             }
54              
55 3 50       13 unless (defined $self->server) {
56 0         0 $self->server($self->dsname);
57             }
58            
59 3         13 my $ds_id = $self->dsid;
60              
61 3 100       8 my $c = eval { UR::DataSource->get($ds_id) || $ds_id->get() };
  3         23  
62 3 100       16 if ($c) {
63 1         18 $self->error_message("A data source named $ds_id already exists\n");
64 1         4 return;
65             }
66              
67 2         15 my $src = $self->_resolve_module_header($ds_id,$namespace);
68              
69 2         14 my($class_definition,$parent_classes) = $self->_resolve_class_definition_source();
70 2         5 $src .= $class_definition;
71              
72 2         11 my $module_body = $self->_resolve_module_body();
73 2         6 $src .= "\n$module_body\n1;\n";
74              
75 2         13 my $module_path = $self->data_source_module_pathname();
76 2         19 my $fh = IO::File->new($module_path, O_WRONLY | O_CREAT | O_EXCL);
77 2 50       406 unless ($fh) {
78 0         0 $self->error_message("Can't open $module_path for writing: $!");
79 0         0 return;
80             }
81              
82 2         29 $fh->print($src);
83 2         38 $fh->close();
84              
85 2         226 $self->status_message("A $ds_id (" . join(',', @$parent_classes) . ")\n");
86              
87 2         9 $self->_post_module_written();
88              
89 2 50       17 if ($self->_try_connect()) {
90 2         22 return 1;
91             } else {
92 0         0 return;
93             }
94             }
95            
96              
97              
98             sub _resolve_module_header {
99 2     2   4 my($self,$ds_id, $namespace) = @_;
100              
101 2         9 return "package $ds_id;\n\nuse strict;\nuse warnings;\n\nuse $namespace;\n\n";
102             }
103              
104             # Subclasses can override this to have something happen after the module
105             # is written, but before we try connecting to the DS
106             sub _post_module_written {
107 0     0   0 return 1;
108             }
109              
110              
111             # Subclasses must override this to indicate what abstract DS class they should
112             # inherit from
113             sub _data_source_sub_class_name {
114 0     0   0 my $self = shift;
115 0         0 my $class = ref($self);
116 0         0 die "Class $class didn't implement _data_source_sub_class_name";
117             }
118              
119              
120             sub _resolve_class_definition_source {
121 2     2   3 my $self = shift;
122            
123 2         8 my $ds_id = $self->dsid;
124              
125 2         8 my $parent_ds_class = $self->_data_source_sub_class_name();
126 2         6 my $src = "class $ds_id {\n";
127              
128 2         4 my @parent_classes = ( $parent_ds_class );
129 2 50       11 if (! $self->nosingleton) {
130 2         8 push @parent_classes, 'UR::Singleton';
131             }
132              
133 2         12 $src .= sprintf(" is => [ '%s' ],\n", join("', '", @parent_classes));
134              
135 2         4 $src .= "};\n";
136              
137 2         6 return($src,\@parent_classes);
138             }
139              
140              
141            
142             sub _resolve_module_body {
143 2     2   3 my $self = shift;
144              
145 2         7 my $server = $self->server;
146 2         6 my $src = "sub server { '$server' }\n";
147              
148 2         4 return $src;
149             }
150              
151              
152              
153             sub _try_connect {
154 2     2   3 my $self = shift;
155              
156 2         5 $self->status_message(" ...connecting...");
157              
158 2         7 my $ds_id = $self->dsid;
159 2         34 my $dbh = $ds_id->get_default_handle();
160 2 50       10 if ($dbh) {
161 2         33 $self->status_message(" ....ok\n");
162 2         8 return 1;
163             } else {
164 0         0 $self->error_message(" ERROR: " . $ds_id->error_message);
165 0         0 return;
166             }
167             }
168              
169              
170              
171             1;
172