line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/bin/perl -T |
2
|
|
|
|
|
|
|
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- |
3
|
|
|
|
|
|
|
# vim:ts=8:sw=2:et:sta:sts=2 |
4
|
|
|
|
|
|
|
######### |
5
|
|
|
|
|
|
|
# Author: rmp |
6
|
|
|
|
|
|
|
# Created: 2007-06-21 |
7
|
|
|
|
|
|
|
# |
8
|
1
|
|
|
1
|
|
534
|
use strict; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
39
|
|
9
|
1
|
|
|
1
|
|
7
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
42
|
|
10
|
1
|
|
|
1
|
|
621
|
use Getopt::Long; |
|
1
|
|
|
|
|
13682
|
|
|
1
|
|
|
|
|
5
|
|
11
|
1
|
|
|
1
|
|
714
|
use English qw(-no_match_vars); |
|
1
|
|
|
|
|
1900
|
|
|
1
|
|
|
|
|
7
|
|
12
|
1
|
|
|
1
|
|
408
|
use Carp; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
90
|
|
13
|
1
|
|
|
1
|
|
471
|
use Template; |
|
1
|
|
|
|
|
21649
|
|
|
1
|
|
|
|
|
32
|
|
14
|
1
|
|
|
1
|
|
520
|
use Lingua::EN::Inflect qw(PL); |
|
1
|
|
|
|
|
21566
|
|
|
1
|
|
|
|
|
122
|
|
15
|
1
|
|
|
1
|
|
328
|
use lib qw(blib/lib lib); |
|
1
|
|
|
|
|
504
|
|
|
1
|
|
|
|
|
5
|
|
16
|
1
|
|
|
1
|
|
511
|
use ClearPress; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
2750
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $VERSION = q[477.1.4]; |
19
|
|
|
|
|
|
|
our $ASPECTS = [qw(read list add create edit update)]; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
local $ENV{PATH} = join q(:), qw(/bin /usr/bin /usr/local/bin /opt/local/bin); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
main(); |
24
|
|
|
|
|
|
|
0; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub main { ## no critic (complexity) |
28
|
1
|
|
|
1
|
|
4
|
my $opts = {}; |
29
|
1
|
|
|
|
|
3
|
my @argvcopy = @ARGV; |
30
|
|
|
|
|
|
|
|
31
|
1
|
|
|
|
|
10
|
GetOptions($opts, |
32
|
|
|
|
|
|
|
'new=s', |
33
|
|
|
|
|
|
|
'driver=s', |
34
|
|
|
|
|
|
|
'yes', |
35
|
|
|
|
|
|
|
'help', |
36
|
|
|
|
|
|
|
'version', |
37
|
|
|
|
|
|
|
); |
38
|
|
|
|
|
|
|
|
39
|
1
|
50
|
|
|
|
582
|
if($opts->{help}) { |
40
|
0
|
0
|
|
|
|
0
|
print <<"EOT" or croak qq[Error printing: $ERRNO]; |
41
|
|
|
|
|
|
|
Usage Example: |
42
|
|
|
|
|
|
|
$PROGRAM_NAME --new GrandKids 'child->family child(name,birthday:date) family(name,address,city,state,zip)' |
43
|
|
|
|
|
|
|
EOT |
44
|
0
|
|
|
|
|
0
|
return 1; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
1
|
50
|
|
|
|
5
|
if($opts->{version}) { |
48
|
0
|
0
|
|
|
|
0
|
print q(ClearPress v).ClearPress->VERSION.qq(\n) or croak qq[Error printing: $ERRNO]; |
49
|
0
|
|
|
|
|
0
|
return 1; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
1
|
|
50
|
|
|
15
|
($opts->{driver}) = ($opts->{driver} || 'mysql') =~ /(SQLite|mysql)/smx; |
53
|
|
|
|
|
|
|
|
54
|
1
|
50
|
|
|
|
5
|
if(!$opts->{new}) { |
55
|
1
|
|
|
|
|
401
|
croak q(Please specify --new ); |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
0
|
|
|
|
|
0
|
my ($app) = $opts->{new} =~ /^([[:lower:]][[:lower:][:digit:]_]+)$/smxi; |
59
|
0
|
|
0
|
|
|
0
|
$app ||= q(); |
60
|
|
|
|
|
|
|
|
61
|
0
|
0
|
|
|
|
0
|
if($app ne $opts->{new}) { |
62
|
0
|
|
|
|
|
0
|
croak q(Invalid characters in application name, only /[a-z][a-z\\d_]+/i allowed.); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
0
|
|
|
|
|
0
|
my $all_structure = shift @ARGV; |
66
|
|
|
|
|
|
|
|
67
|
0
|
|
|
|
|
0
|
my $schema = {}; |
68
|
0
|
|
|
|
|
0
|
my $driver_pkg = "ClearPress::driver::$opts->{driver}"; |
69
|
|
|
|
|
|
|
|
70
|
0
|
|
|
|
|
0
|
eval "require $driver_pkg"; ## no critic (ProhibitStringyEval RequireCheckingReturnValueOfEval) |
71
|
0
|
|
|
|
|
0
|
my $driver = $driver_pkg->new(); |
72
|
|
|
|
|
|
|
|
73
|
0
|
|
|
|
|
0
|
for my $structure (split /\s+/smx, $all_structure) { |
74
|
0
|
0
|
|
|
|
0
|
if($structure =~ /\S+[(]\S+[)]/smx) { |
|
|
0
|
|
|
|
|
|
75
|
|
|
|
|
|
|
######### |
76
|
|
|
|
|
|
|
# table definition |
77
|
|
|
|
|
|
|
# |
78
|
0
|
|
|
|
|
0
|
my ($table, $columns) = $structure =~ /(\S+)[(](\S+)[)]/smx; |
79
|
|
|
|
|
|
|
|
80
|
0
|
|
|
|
|
0
|
for my $column (split /,/smx, $columns) { |
81
|
0
|
|
|
|
|
0
|
my ($name, $type) = split /:/smx, $column; |
82
|
0
|
|
0
|
|
|
0
|
$name ||= $column; |
83
|
0
|
|
0
|
|
|
0
|
$type = $driver->type_map($type||'char(128)'); |
84
|
0
|
|
|
|
|
0
|
$schema->{$table}->{fields}->{$name} = $type; |
85
|
|
|
|
|
|
|
|
86
|
0
|
0
|
|
|
|
0
|
print {*STDERR} qq($table has $name of type $type\n) or croak qq[Error printing: $ERRNO]; |
|
0
|
|
|
|
|
0
|
|
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
} elsif($structure =~ /\S+\->\S+/smx) { |
90
|
|
|
|
|
|
|
######### |
91
|
|
|
|
|
|
|
# relationship |
92
|
|
|
|
|
|
|
# |
93
|
0
|
|
|
|
|
0
|
my ($one, $many) = $structure =~ /(\S+)\->(\S+)/smx; |
94
|
0
|
|
|
|
|
0
|
push @{$schema->{$one}->{has_a}}, $many; |
|
0
|
|
|
|
|
0
|
|
95
|
0
|
|
|
|
|
0
|
push @{$schema->{$many}->{has_many}}, $one; |
|
0
|
|
|
|
|
0
|
|
96
|
0
|
0
|
|
|
|
0
|
print {*STDERR} qq($one has a $many\n$many has many @{[PL($one)]}\n) or croak qq[Error printing: $ERRNO]; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
0
|
|
|
|
|
0
|
my $template_cache = {}; |
101
|
0
|
|
|
|
|
0
|
read_templates($template_cache); |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
create_application({ |
104
|
|
|
|
|
|
|
'template_cache' => $template_cache, |
105
|
|
|
|
|
|
|
'application' => $app, |
106
|
0
|
|
|
|
|
0
|
'views' => [keys %{$schema}], |
107
|
|
|
|
|
|
|
'yes' => exists $opts->{yes}, |
108
|
|
|
|
|
|
|
'driver' => $opts->{driver}, |
109
|
0
|
|
|
|
|
0
|
'schema' => $schema, |
110
|
|
|
|
|
|
|
}); |
111
|
|
|
|
|
|
|
|
112
|
0
|
|
|
|
|
0
|
my $precedence = [map { $_->{name} } |
113
|
|
|
|
|
|
|
sort _sorter |
114
|
0
|
|
|
|
|
0
|
values %{$schema}]; |
|
0
|
|
|
|
|
0
|
|
115
|
|
|
|
|
|
|
|
116
|
0
|
|
|
|
|
0
|
my $cfg = qq($app/config.layout); |
117
|
0
|
0
|
|
|
|
0
|
open my $fh, q(>), $cfg or croak qq[Error opening $cfg: $ERRNO]; |
118
|
0
|
0
|
|
|
|
0
|
print {$fh} $PROGRAM_NAME, (map { qq( '$_') } @argvcopy), qq(\n) or croak qq[Error printing: $ERRNO]; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
119
|
0
|
0
|
|
|
|
0
|
close $fh or croak qq[Error closing $cfg: $ERRNO]; |
120
|
|
|
|
|
|
|
|
121
|
0
|
0
|
|
|
|
0
|
if($opts->{driver} eq 'mysql') { |
122
|
|
|
|
|
|
|
######### |
123
|
|
|
|
|
|
|
# mysql message |
124
|
|
|
|
|
|
|
# |
125
|
0
|
0
|
|
|
|
0
|
print <<"EOT" or croak qq[Error printing: $ERRNO]; |
126
|
|
|
|
|
|
|
You now need to configure your database. |
127
|
|
|
|
|
|
|
1. Check and/or modify $app/data/config.ini |
128
|
|
|
|
|
|
|
2. If necessary create a database, something like this: |
129
|
|
|
|
|
|
|
mysqladmin -uroot create $app |
130
|
0
|
|
|
|
|
0
|
3. cat @{[map { "$app/data/schema/$_.mysql \\\n " } @{$precedence}]} | mysql -uroot $app |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
Note you may need to create your new schema in order, depending on your foreign key constraints. |
133
|
|
|
|
|
|
|
EOT |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
} else { |
136
|
|
|
|
|
|
|
######### |
137
|
|
|
|
|
|
|
# SQLite message |
138
|
|
|
|
|
|
|
# |
139
|
0
|
0
|
|
|
|
0
|
print <<"EOT" or croak qq[Error printing: $ERRNO]; |
140
|
|
|
|
|
|
|
You now need to configure your database. |
141
|
|
|
|
|
|
|
1. Check and/or modify $app/data/config.ini |
142
|
|
|
|
|
|
|
2. If necessary create a database, something like this: |
143
|
|
|
|
|
|
|
cat $app/data/schema/*.SQLite | sqlite3 $app/$app |
144
|
|
|
|
|
|
|
EOT |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
0
|
|
|
|
|
0
|
return 1; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
sub read_templates { |
151
|
0
|
|
|
0
|
|
0
|
my $cache = shift; |
152
|
0
|
|
|
|
|
0
|
local $RS = "\n-- \n"; |
153
|
|
|
|
|
|
|
|
154
|
0
|
0
|
|
|
|
0
|
if(!scalar keys %{$cache}) { |
|
0
|
|
|
|
|
0
|
|
155
|
0
|
|
|
|
|
0
|
for my $field (qw(config schema_mysql schema_SQLite application_sa application_cgi util model view view_error), |
156
|
0
|
|
|
|
|
0
|
(map { "aspect_$_" } @{$ASPECTS}), |
|
0
|
|
|
|
|
0
|
|
157
|
|
|
|
|
|
|
qw(actions warnings stylesheet)) { |
158
|
0
|
|
|
|
|
0
|
my $str = ; |
159
|
0
|
|
|
|
|
0
|
$str =~ s/$RS//smx; |
160
|
0
|
|
|
|
|
0
|
$cache->{$field} = \$str; |
161
|
0
|
0
|
|
|
|
0
|
print qq(Read @{[length($str)]} bytes for $field\n) or croak qq[Error printing: $ERRNO]; |
|
0
|
|
|
|
|
0
|
|
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
} |
164
|
0
|
|
|
|
|
0
|
return 1; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub create_application { |
168
|
0
|
|
|
0
|
|
0
|
my $opts = shift; |
169
|
0
|
|
|
|
|
0
|
my $app = $opts->{application}; |
170
|
0
|
|
|
|
|
0
|
my $cache = $opts->{template_cache}; |
171
|
0
|
|
|
|
|
0
|
my $driver = $opts->{driver}; |
172
|
0
|
|
|
|
|
0
|
my $schema = $opts->{schema}; |
173
|
0
|
|
|
|
|
0
|
my $tt = Template->new({ |
174
|
|
|
|
|
|
|
EVAL_PERL => 1, |
175
|
|
|
|
|
|
|
TAG_STYLE => 'asp', |
176
|
|
|
|
|
|
|
}); |
177
|
|
|
|
|
|
|
|
178
|
0
|
|
|
|
|
0
|
for my $view (@{$opts->{views}}) { |
|
0
|
|
|
|
|
0
|
|
179
|
0
|
|
|
|
|
0
|
$schema->{$view}->{name} = $view; |
180
|
0
|
|
|
|
|
0
|
$opts->{name} = $view; |
181
|
|
|
|
|
|
|
$opts->{fields} = [map { {name => $_, |
182
|
0
|
|
|
|
|
0
|
type => $schema->{$view}->{fields}->{$_}}; |
183
|
0
|
|
|
|
|
0
|
} sort keys %{$schema->{$view}->{fields} }]; |
|
0
|
|
|
|
|
0
|
|
184
|
0
|
|
0
|
|
|
0
|
$opts->{has_many} = $schema->{$view}->{has_many} || []; |
185
|
0
|
|
0
|
|
|
0
|
$opts->{has_a} = $schema->{$view}->{has_a} || []; |
186
|
|
|
|
|
|
|
|
187
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{"schema_$driver"}, "$app/data/schema", "$view.$driver"); |
188
|
|
|
|
|
|
|
|
189
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{model}, "$app/lib/$app/model", "$view.pm"); |
190
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{view}, "$app/lib/$app/view", "$view.pm"); |
191
|
|
|
|
|
|
|
|
192
|
0
|
|
|
|
|
0
|
for my $aspect (@{$ASPECTS}) { |
|
0
|
|
|
|
|
0
|
|
193
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{"aspect_$aspect"}, "$app/data/templates", "${view}_$aspect.tt2"); |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{util}, "$app/lib/$app", 'util.pm'); |
198
|
|
|
|
|
|
|
|
199
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{view_error}, "$app/lib/$app/view", 'error.pm'); |
200
|
|
|
|
|
|
|
|
201
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{config}, "$app/data", 'config.ini'); |
202
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{application_cgi}, "$app/cgi-bin", $app); |
203
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{application_sa}, "$app/bin", $app); |
204
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{stylesheet}, "$app/htdocs", "$app.css"); |
205
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{actions}, "$app/data/templates", 'actions.tt2'); |
206
|
0
|
|
|
|
|
0
|
process_template($opts, $tt, $cache->{warnings}, "$app/data/templates", 'warnings.tt2'); |
207
|
|
|
|
|
|
|
|
208
|
0
|
|
|
|
|
0
|
return 1; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub _yn { |
212
|
0
|
|
|
0
|
|
0
|
my ($default) = @_; |
213
|
0
|
|
|
|
|
0
|
local $RS = "\n"; |
214
|
0
|
|
|
|
|
0
|
my $response = <>; |
215
|
0
|
|
|
|
|
0
|
chomp $response; |
216
|
0
|
|
0
|
|
|
0
|
$response ||= $default; |
217
|
0
|
|
|
|
|
0
|
return (uc $response eq uc $default) |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
sub process_template { |
221
|
0
|
|
|
0
|
|
0
|
my ($opts, $tt, $tmpl, $path, $fn) = @_; |
222
|
|
|
|
|
|
|
|
223
|
0
|
|
|
|
|
0
|
$fn = "$path/$fn"; |
224
|
|
|
|
|
|
|
|
225
|
0
|
0
|
0
|
|
|
0
|
if(!$opts->{yes} && -e $fn) { |
226
|
0
|
0
|
|
|
|
0
|
print "$fn exists. Overwrite? [y/N] " or croak qq[Error printing: $ERRNO]; |
227
|
0
|
0
|
|
|
|
0
|
_yn('N') and return 1; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
0
|
|
|
|
|
0
|
system qw(mkdir -p), $path; |
231
|
0
|
0
|
|
|
|
0
|
open my $fh, q[>], $fn or croak "Opening $fn: $ERRNO"; |
232
|
0
|
0
|
|
|
|
0
|
$tt->process($tmpl, $opts, $fh) or croak "Template error building $fn: ".$tt->error(). "\nTemplate was:\n".${$tmpl}."\n"; |
|
0
|
|
|
|
|
0
|
|
233
|
0
|
0
|
|
|
|
0
|
close $fh or croak "Closing $fn: $ERRNO"; |
234
|
0
|
|
|
|
|
0
|
return 1; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub _sorter { |
238
|
18
|
100
|
|
18
|
|
5168
|
my $a_deps = [@{$a->{has_a}||[]}];#, @{$a->{has_many}||[]}]; |
|
18
|
|
|
|
|
78
|
|
239
|
18
|
100
|
|
|
|
35
|
my $b_deps = [@{$b->{has_a}||[]}];#, @{$b->{has_many}||[]}]; |
|
18
|
|
|
|
|
70
|
|
240
|
|
|
|
|
|
|
|
241
|
18
|
100
|
|
|
|
34
|
if(scalar grep { $_ eq $b->{name} } @{$a_deps}) { |
|
11
|
|
|
|
|
46
|
|
|
18
|
|
|
|
|
38
|
|
242
|
4
|
|
|
|
|
20
|
return 1; |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
14
|
100
|
|
|
|
22
|
if(scalar grep { $_ eq $a->{name} } @{$b_deps}) { |
|
13
|
|
|
|
|
50
|
|
|
14
|
|
|
|
|
31
|
|
246
|
6
|
|
|
|
|
22
|
return -1; ## no critic (ProhibitMagicNumbers) |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
8
|
|
66
|
|
|
14
|
return (scalar @{$a_deps} <=> scalar @{$b_deps} || $a->{name} cmp $b->{name}); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
__END__ |