File Coverage

blib/lib/AutoSQL/SQLGenerator.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package AutoSQL::SQLGenerator;
2 1     1   5 use strict;
  1         2  
  1         137  
3 1     1   1644 use AutoCode::Root;
  0            
  0            
4             our @ISA=qw(AutoCode::Root);
5             our $category_scale_map = {
6             c => {
7             8=>'CHAR',
8             16=>'TEXT',
9             24=>'MEDIUMTEXT',
10             32=>'LONGTEXT',
11             },
12             v=>{8=>'VARCHAR'},
13            
14             i=>{
15             8=>'TINYINT',
16             16=>'SMALLINT',
17             24=>'MEDIUMINT',
18             32=>'INT',
19             64=>'BIGINT'
20             },
21             f=>{
22             24=>'FLOAT',
23             53=>'DOUBLE'
24             },
25             t=>{
26             1=>'TIME',
27             2=>'DATE',
28             3=>'DATETIME',
29             4=>'TIMESTAMP'
30             },
31             };
32              
33             sub _initialize { }
34              
35              
36             sub generate_table_sql {
37             my $self=shift;
38             my $schema=shift;
39             my %tables=$self->_get_tables_from_schema($schema);
40             my @sql;
41             foreach my $table (sort keys %tables){
42             my %table=%{$tables{$table}};
43             my @column_sql;
44             push @column_sql , "${table}_id INT UNSIGNED NOT NULL AUTO_INCREMENT";
45             my @fks;
46              
47             foreach my $column (keys %table){
48             local $_ = $table{$column};
49             if(s/^!//g){
50             push @fks, ($column. ((length)?'':'_id'));
51             }
52             push @column_sql,
53             (length)?"$column $_":"${column}_id INT UNSIGNED NOT NULL";
54             }
55              
56             push @column_sql, "PRIMARY KEY (${table}_id)";
57             push @column_sql, map{"KEY ($_)"}@fks;
58             my $sql = join(",\n", map{ ' 'x4 . $_} @column_sql); # s/\n/\n /g;
59             $sql = "CREATE TABLE $table (\n".$sql;
60             $sql .="\n)\n";
61             push @sql, $sql;
62             }
63             # Make the joint tables
64             foreach my $friend (sort $schema->get_friends){
65             $friend =~ s/;$//;
66             my @columns = split /;/, $friend;
67             my @pair=split /-/, shift @columns;
68              
69             }
70             return @sql;
71             }
72              
73             sub _get_tables_from_schema {
74             my ($self, $schema)=@_;
75             my %tables;
76             foreach my $type($schema->get_all_types){
77             my $module = $schema->get_table_model($type);
78             next if $module->get_directive_attribute('$tablized') == -1;
79             my $table_name=$module->table_name;
80             # $self->throw("$table_name has existed")if exists $tables{$table_name};
81             $tables{$table_name}={} unless exists $tables{$table_name};
82             foreach($module->get_scalar_attributes){
83             my ($context, $kind, $content, $required) =
84             $module->_classify_value_attribute($_);
85             if($kind eq'M'){
86             # This is 1-to-0-or-1 parent-child relationship.
87             # Child table should have a parent_id.
88             # $datatype_sql='!';
89             my $ref_table=$schema->get_table_model($content)->table_name;
90             $tables{$ref_table}={} unless exists $tables{$ref_table};
91             $tables{$ref_table}->{$table_name}='!';
92             }else{
93             my $datatype_sql;
94             if($kind eq'P'){
95             $datatype_sql = $self->_translate_datatype($content);
96             }elsif($kind eq'E'){
97             $datatype_sql=$self->_translate_enum($content);
98             }
99            
100             $tables{$table_name}->{$_}=
101             $datatype_sql .($required?' NOT NULL':'');
102             }
103             }
104             foreach my $attr ($module->get_array_attributes){
105             my ($context, $kind, $content, $required) =
106             $module->_classify_value_attribute($attr);
107             if($kind eq 'P'){
108             my $joint_table="$table_name\_$attr";
109             $tables{$joint_table}={};
110             $tables{$joint_table}->{$table_name}='!';
111             $tables{$joint_table}->{$attr}=
112             $self->_translate_datatype($content);
113             }elsif($kind eq 'M'){
114             my $ref_table= $schema->get_table_model($content)->table_name;
115             $tables{$ref_table}={} unless exists $tables{$ref_table};
116             $tables{$ref_table}->{$table_name}='!';
117            
118             }
119             }
120             } # foreach $type
121              
122             foreach my $friendship ($schema->get_friendships){
123             my @peers = $friendship->get_peers;
124             my @peer_names=map{$schema->get_table_model($_)->table_name;}@peers;
125             my $table_name=join '_', @peer_names;
126             my %friendship_table;
127             # $friendship_table{$table_name}='!';
128             map{$friendship_table{"$_\_id"}='!';}@peer_names;
129            
130             $friendship_table{'junkSeeSQLGenerator'.__LINE__}='INT';
131             $tables{$table_name}=\%friendship_table;
132            
133             }
134            
135             return %tables;
136             }
137              
138             sub _translate_enum {
139             my ($self, $enum)=@_;
140             return 'ENUM('. join(', ', map {"'$_'"} split "\s", $enum) .')';
141             }
142              
143             sub _translate_datatype {
144             my ($self, $datatype)=@_;
145             $self->throw("[$datatype] does not match the pattern")
146             unless my ($category, undef, $precision, $scale, $unsigned) =
147             $datatype =~ /^([CVIDFTcvidft])(([\+\^]?[\d]+)(\.\d+)?)?([U|u]?)$/;
148             $self->throw("cvt should not come with u")
149             if($category =~ /[cvt]/ and $unsigned);
150             return $self->__translate_time_datatype($precision) if $category eq 't';
151             if ($precision){
152             $precision=~s/^\^/2**/;
153             $precision=~s/^\+/10**/;
154             $precision = eval $precision;
155             }else{
156             $precision=8;
157             }
158             my $precision_scale = log($precision)/log(2);
159             $precision_scale = $self->_floor($precision_scale);
160              
161             $self->throw("[$category,$precision_scale] does not exists")
162             unless exists $category_scale_map->{$category}->{$precision_scale};
163             my $type = $category_scale_map->{$category}->{$precision_scale};
164             if($type eq 'CHAR'){$type .= "($precision)";}
165             if($type eq 'VARCHAR'){$type .="($precision)";}
166             return $type . ($unsigned?' UNSIGNED':'');
167             }
168              
169             sub __translate_time_datatype {
170             my ($self, $precision)=@_;
171             $precision ||= 3;
172             return $category_scale_map->{t}->{$precision};
173             }
174              
175             sub _floor {
176             my ($self, $v)=@_;
177             if($v<8){$v=8;}
178             elsif($v<16){$v=16;}
179             elsif($v<24){$v=24;}
180             elsif($v<32){$v=32;}
181             elsif($v<64){$v=64;}
182             return $v;
183             }
184              
185             sub _precision_scale_2_prefix {
186             my ($self, $scale, $category)=@_;
187             my $prefix;
188             if($scale <8){ $prefix ='TINY';
189             }elsif($scale<16){ $prefix = 'SMALL';
190             }elsif($scale<24){$prefix='MEDIUM';
191             }elsif($scale<32){$prefix='';
192             }elsif($scale<64){$prefix=($category eq'C')?'LONG':'BIG';
193             }else{ $self->throw('scale is bigger than 64'); }
194             return $prefix;
195             }
196              
197             1;
198