File Coverage

blib/lib/Cog/Config.pm
Criterion Covered Total %
statement 21 150 14.0
branch 0 72 0.0
condition 0 10 0.0
subroutine 7 18 38.8
pod 0 10 0.0
total 28 260 10.7


line stmt bran cond sub pod time code
1             # TODO:
2             # - Support uri_base
3             # - Support uri_port
4             # - Support uri_path
5             # - Support daemon, logfile and pid
6             # - plugins can update config to map urls to code
7             # - Make all config options 'foo' respect $COG_FOO
8              
9             package Cog::Config;
10 2     2   3198 use Mo qw'build builder default required';
  2         4  
  2         11  
11              
12 2     2   6587 use File::ShareDir;
  2         10648  
  2         102  
13 2     2   12 use Cwd qw(abs_path);
  2         2  
  2         72  
14 2     2   8 use IO::All;
  2         3  
  2         16  
15              
16             ### These options are set by user in config file:
17              
18             # Common webapp options
19             has home_page_id => ();
20              
21             # Server options
22             has server_host => (default => 'localhost');
23             has server_port => (default => '12345');
24             has proxymap => ();
25             has cache_urls => ();
26              
27             ### These fields are part of the Cog framework:
28              
29             # Bootstrapping config values
30             my $app;
31 0     0 0   sub app { $app }
32             has app_class => required => 1;
33              
34             # App Command Values
35             has cli_args => (default => sub{[]});
36              
37             # App & WebApp definitions
38             has url_map => (default => sub{[]});
39             has post_map => (default => sub{[]});
40             has coffee_files => (default => sub{[]});
41             has js_files => (default => sub{[]});
42             has css_files => (default => sub{[]});
43             has image_files => (default => sub{[]});
44             has template_files => (default => sub{[]});
45             has site_navigation => (default => sub{[]});
46             has files_map => (builder => '_build_files_map', lazy => 1);
47             has all_js_file => ();
48             has all_css_file => ();
49              
50             # App readiness
51             has is_init => (default => 0);
52             has is_config => (default => 0);
53             has is_ready => (default => 0);
54              
55             # Private accessors
56             has _plugins => (default => sub{[]});
57             has _class_share_map => (default => sub{{}});
58              
59              
60             # Build the config object scanning through all the classes and merging
61             # their capabilites together appropriately.
62             #
63             # This is the hard part...
64             sub BUILD {
65 0     0 0   my $self = shift;
66 0           $app = delete $self->{app};
67              
68 0           my $root = $self->app->app_root;
69 0 0         $self->{is_init} = 1
70             if -d "$root/static";
71 0 0         $self->{is_config} = 1
72             if -e "$root/config.yaml";
73 0 0         $self->{is_ready} = 1
74             if -d "$root/static";
75              
76 0           $self->build_plugin_list();
77              
78 0           $self->build_class_share_map();
79              
80 0           $self->build_list('url_map', 'lol');
81 0           $self->build_list('post_map', 'lol');
82 0           $self->build_list('site_navigation', 'lol');
83              
84 0           $self->build_list('coffee_files');
85 0           $self->build_list('js_files');
86 0           $self->build_list('css_files');
87 0           $self->build_list('image_files');
88 0           $self->build_list('template_files');
89              
90 0           return $self;
91             }
92              
93             sub build_plugin_list {
94 0     0 0   my $self = shift;
95 0           my $list = [];
96 0           my $expanded = {};
97 0           $self->expand_list($list, $self->app_class, $expanded);
98              
99 0           $self->{_plugins} = $list;
100             }
101              
102             sub expand_list {
103 0     0 0   my ($self, $list, $plugin, $expanded) = @_;
104 0 0         return if $expanded->{$plugin};
105 0           $expanded->{$plugin} = 1;
106 0           eval "use $plugin";
107 0 0 0       die "use $plugin; error: $@"
108             if $@ and $@ !~ /Can't locate/;
109 0           unshift @$list, $plugin;
110 0           my $adds = [];
111 0           my $parent;
112             {
113 2     2   1081 no strict 'refs';
  2         4  
  2         625  
  0            
114 0           $parent = ${"${plugin}::ISA"}[0];
  0            
115             }
116 0 0         if ($plugin->isa('Cog::App')) {
    0          
117 0 0         if ($plugin->webapp_class) {
118 0           push @$adds, $plugin->webapp_class;
119             }
120 0 0         push @$adds, $parent
121             unless $parent =~ /^(Cog::Base|Cog::Plugin)$/;
122             }
123             elsif ($plugin->isa('Cog::WebApp')) {
124 0 0         push @$adds, $parent
125             unless $parent =~ /^(Cog::Base|Cog::Plugin)$/;
126             }
127 0           push @$adds, @{$plugin->plugins};
  0            
128              
129 0           for my $add (@$adds) {
130 0           $self->expand_list($list, $add, $expanded);
131             }
132             }
133              
134             sub build_list {
135 0     0 0   my $self = shift;
136 0           my $name = shift;
137 0   0       my $list_list = shift || 0;
138 0           my $finals = $self->$name;
139 0           my $list = [];
140 0           my $plugins = $self->_plugins;
141 0 0         my $method = $list_list ? 'add_to_list_list' : 'add_to_list';
142 0           for my $plugin (@$plugins) {
143 0           my $function = "${plugin}::$name";
144 0 0         next unless defined(&$function);
145 2     2   10 no strict 'refs';
  2         3  
  2         1188  
146 0           $self->$method($list, &$function());
147             }
148 0           $self->$method($list, $finals);
149 0           $self->{$name} = $list;
150             }
151              
152             sub add_to_list {
153 0     0 0   my ($self, $list, $adds) = @_;
154 0           my $point = @$list;
155 0           for my $add (@$adds) {
156 0 0         if ($add eq '()') {
    0          
    0          
    0          
    0          
    0          
157 0           $point = @$list = ();
158             }
159             elsif ($add eq '^^') {
160 0           $point = 0;
161             }
162             elsif ($add eq '$$') {
163 0           $point = @$list;
164             }
165             elsif ($add eq '++') {
166 0 0         $point++ if $point < @$list;
167             }
168             elsif ($add eq '--') {
169 0 0         $point-- if $point > 0;
170             }
171             elsif ($add =~ s/^(\-\-|\+\+) *//) {
172 0           my $indicator = $1;
173 0           for ($point = 0; $point < @$list; $point++) {
174 0 0         if ($add eq $list->[$point]) {
175 0 0         splice(@$list, $point, 1)
176             if $indicator eq '--';
177 0 0         $point++
178             if $indicator eq '++';
179 0           last;
180             }
181             }
182             }
183             else {
184 0           splice(@$list, $point++, 0, $add);
185             }
186             }
187             }
188              
189             sub add_to_list_list {
190 0     0 0   my ($self, $list, $adds) = @_;
191 0           my $point = @$list;
192 0           for my $add (@$adds) {
193 0 0 0       if (not ref $add and $add eq '()') {
194 0           $point = @$list = ();
195             }
196             else {
197 0           splice(@$list, $point++, 0, $add);
198             }
199             }
200             }
201              
202             sub build_class_share_map {
203 0     0 0   my $self = shift;
204 0           my $plugins = $self->_plugins;
205 0           my $class_share_map = $self->_class_share_map;
206 0           for my $plugin (@$plugins) {
207 0 0         my $dir = $self->find_share_dir($plugin)
208             or die "Can't find share dir for $plugin";
209 0 0         $class_share_map->{$plugin} = $dir
210             if $dir;
211             }
212             }
213              
214             sub find_share_dir {
215 0     0 0   my $self = shift;
216 0           my $plugin = shift;
217              
218 0           my $dist = $plugin->DISTNAME;
219 0           my $modpath = "$dist.pm";
220 0           $modpath =~ s!-!/!g;
221              
222 0           while (1) {
223 0 0         my $dir = $INC{$modpath} or last;
224 0 0         $dir =~ s!(blib/)?lib/\Q$modpath\E$!! or last;
225 0           $dir .= "share";
226 0 0         return $dir if -e $dir;
227 0           last;
228             }
229              
230 0           my $dir = eval { File::ShareDir::dist_dir($dist) };
  0            
231 0 0         return $dir if $dir;
232              
233 0           return;
234             }
235              
236             sub _build_files_map {
237 0     0     my $self = shift;
238              
239 0           my $hash = {};
240              
241 0           my $plugins = $self->_plugins;
242              
243 0           for my $plugin (@$plugins) {
244 0 0         my $dir = $self->_class_share_map->{$plugin} or next;
245 0           for (io->dir($dir)->All_Files) {
246 0 0         next if "$_" =~ /\.(sw[p]|packlist)$/;
247 0           my $full = $_->pathname;
248 0           my $short = $full;
249 0 0         $short =~ s!^\Q$dir\E/?!! or die;
250 0           $hash->{$short} = [$plugin => $full];
251             }
252             }
253              
254 0           return $hash;
255             }
256              
257 2         507 use constant namespace_map => {
258             'app/app_class' => 'app_class',
259             'app/webapp_class' => 'webapp_class',
260             'server/port' => 'server_port',
261             'server/host' => 'server_host',
262 2     2   10 };
  2         3  
263             sub flatten_namespace {
264 0     0 0   my ($class, $hash, $path) = @_;
265 0   0       $path ||= '';
266 0           my $map = $class->namespace_map;
267 0           my $ns = {};
268 0           for my $key (keys %$hash) {
269 0           my $value = $hash->{$key};
270 0 0         my $name = $path ? "$path/$key" : $key;
271 0 0         if (ref($value) eq 'HASH') {
    0          
272 0           $ns = { %$ns, %{$class->flatten_namespace($value, $name)} };
  0            
273             }
274             elsif ($map->{$name}) {
275 0           $ns->{$map->{$name}} = $value;
276             }
277             else {
278 0           my $root = $ns;
279 0           my @keys = split '/', $name;
280 0           my $leaf = pop @keys;
281 0           for my $k (@keys) {
282 0           $root = $root->{$k} = {};
283             }
284 0           $root->{$leaf} = $value;
285             }
286             }
287 0           return $ns;
288             }
289              
290             1;