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	dpavlin	1093	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	dpavlin	1133	__PACKAGE__->meta->make_immutable;
145			no Moose;
146
147	dpavlin	1093	1;