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	dpavlin	1093	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;