Frey/Class/Schematize.pm

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

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

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

__PACKAGE__->meta->make_immutable;
no Moose;

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