File Coverage

bin/clearpress
Criterion Covered Total %
statement 48 159 30.1
branch 11 56 19.6
condition 3 22 13.6
subroutine 11 15 73.3
pod n/a
total 73 252 28.9


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__