Frey/Class/Schematize.pm

package Frey::Class::Schematize;
use Moose;

extends 'Frey::Class::Loader';
extends 'Frey::PPI';
with 'Frey::Web';
#with 'Frey::Storage';

has class => (
        is => 'rw',
        isa => 'Str',
        required => 1,
        default => 'App::RoomReservation::Reservation',
);

sub create_table_as_markup {
        my ($self) = @_;
        qq|<pre>| . $self->create_table . qq|</pre>|;
}

use DBI;

sub create_table {
        my ($self) = @_;

        my ( $meta, $is_role, $instance ) = $self->class_meta( $self->class );

        my $columns;
        map {
                $columns->{ $_->name } = attribute($_);
        } $meta->get_all_attributes;

        my @order = $self->attribute_order;

        return
                header($meta)
                . join(",\n\t",
                        "\tid SERIAL",
                        map { $columns->{$_} } @order
                )
                . footer()
                ;

}

sub class_to_table {
        my $class = shift;
        $class =~ s{App::[^:]+::}{};
        my $table = lc $class;
        $table =~ s/::/_/g;
        return $table;
}

sub header {
        my $meta = shift;

        my $name = class_to_table($meta->name);

        return "CREATE TABLE $name (\n";
}

sub footer { "\n);\n" }

sub attribute {
        my $attribute = shift;
        my @constraints;

        push @constraints, type_of($attribute);
        push @constraints, 'NOT NULL' if $attribute->is_required;
        push @constraints, default_of($attribute);
        push @constraints, foreign_key_of($attribute);

        return join ' ', $attribute->name, @constraints;
}

sub type_of {
        my $attribute = shift;

        return if !$attribute->has_type_constraint;
        my $tc = $attribute->type_constraint;

        my @type_mapping = (
                [Int => 'INTEGER'],
                [Num => 'REAL'],
                [Str => 'TEXT'],
                [Bool => 'BOOLEAN'],
        );

        for (@type_mapping) {
                my ($moose_type, $sql_type) = @$_;
                return $sql_type
                        if $tc->is_a_type_of($moose_type);
        }

        return;
}

sub default_of {
        my $attribute = shift;

        return unless $attribute->has_default;

        my $default;
        if ( $attribute->is_default_a_coderef ) {
                $default = eval { $attribute->default->(); };
                if ( $@ ) {
                        warn "can't eval default: $@";
                        return;
                }
                my $type = type_of($attribute);
                if ( $type eq 'BOOLEAN' ) {
                        return ('DEFAULT', $default ? 'TRUE' : 'FALSE');
                }
        } else {
                $default = $attribute->default;
        }

        if ($default =~ /^\d+$/ ) {
                return ('DEFAULT', $default);
        }

        return ('DEFAULT', DBD::_::db->quote($default));
}

sub foreign_key_of {
        my $attribute = shift;

        return if !$attribute->has_type_constraint;
        my $tc = $attribute->type_constraint;

        return if !$tc->isa('Moose::Meta::TypeConstraint::Class');
        my $table = class_to_table($tc->class);

        return ('REFERENCES', $table, '(id)');
}

=head1 SEE ALSO

Based on code from L<http://github.com/sartak/mmop/raw/master/2-schema-generator.pl>

L<http://blog.sartak.org/2009/06/mooses-mop-schematize.html>

=cut

1;
1	package Frey::Class::Schematize;
2	use Moose;
3
4	extends 'Frey::Class::Loader';
5	extends 'Frey::PPI';
6	with 'Frey::Web';
7	#with 'Frey::Storage';
8
9	has class => (
10	is => 'rw',
11	isa => 'Str',
12	required => 1,
13	default => 'App::RoomReservation::Reservation',
14	);
15
16	sub create_table_as_markup {
17	my ($self) = @_;
18	qq\|<pre>\| . $self->create_table . qq\|</pre>\|;
19	}
20
21	use DBI;
22
23	sub create_table {
24	my ($self) = @_;
25
26	my ( $meta, $is_role, $instance ) = $self->class_meta( $self->class );
27
28	my $columns;
29	map {
30	$columns->{ $_->name } = attribute($_);
31	} $meta->get_all_attributes;
32
33	my @order = $self->attribute_order;
34
35	return
36	header($meta)
37	. join(",\n\t",
38	"\tid SERIAL",
39	map { $columns->{$_} } @order
40	)
41	. footer()
42	;
43
44	}
45
46	sub class_to_table {
47	my $class = shift;
48	$class =~ s{App::[^:]+::}{};
49	my $table = lc $class;
50	$table =~ s/::/_/g;
51	return $table;
52	}
53
54	sub header {
55	my $meta = shift;
56
57	my $name = class_to_table($meta->name);
58
59	return "CREATE TABLE $name (\n";
60	}
61
62	sub footer { "\n);\n" }
63
64	sub attribute {
65	my $attribute = shift;
66	my @constraints;
67
68	push @constraints, type_of($attribute);
69	push @constraints, 'NOT NULL' if $attribute->is_required;
70	push @constraints, default_of($attribute);
71	push @constraints, foreign_key_of($attribute);
72
73	return join ' ', $attribute->name, @constraints;
74	}
75
76	sub type_of {
77	my $attribute = shift;
78
79	return if !$attribute->has_type_constraint;
80	my $tc = $attribute->type_constraint;
81
82	my @type_mapping = (
83	[Int => 'INTEGER'],
84	[Num => 'REAL'],
85	[Str => 'TEXT'],
86	[Bool => 'BOOLEAN'],
87	);
88
89	for (@type_mapping) {
90	my ($moose_type, $sql_type) = @$_;
91	return $sql_type
92	if $tc->is_a_type_of($moose_type);
93	}
94
95	return;
96	}
97
98	sub default_of {
99	my $attribute = shift;
100
101	return unless $attribute->has_default;
102
103	my $default;
104	if ( $attribute->is_default_a_coderef ) {
105	$default = eval { $attribute->default->(); };
106	if ( $@ ) {
107	warn "can't eval default: $@";
108	return;
109	}
110	my $type = type_of($attribute);
111	if ( $type eq 'BOOLEAN' ) {
112	return ('DEFAULT', $default ? 'TRUE' : 'FALSE');
113	}
114	} else {
115	$default = $attribute->default;
116	}
117
118	if ($default =~ /^\d+$/ ) {
119	return ('DEFAULT', $default);
120	}
121
122	return ('DEFAULT', DBD::_::db->quote($default));
123	}
124
125	sub foreign_key_of {
126	my $attribute = shift;
127
128	return if !$attribute->has_type_constraint;
129	my $tc = $attribute->type_constraint;
130
131	return if !$tc->isa('Moose::Meta::TypeConstraint::Class');
132	my $table = class_to_table($tc->class);
133
134	return ('REFERENCES', $table, '(id)');
135	}
136
137	=head1 SEE ALSO
138
139	Based on code from L<http://github.com/sartak/mmop/raw/master/2-schema-generator.pl>
140
141	L<http://blog.sartak.org/2009/06/mooses-mop-schematize.html>
142
143	=cut
144
145	1;