File Coverage

blib/lib/Config/JSON.pm
Criterion Covered Total %
statement 18 20 90.0
branch n/a
condition n/a
subroutine 6 7 85.7
pod n/a
total 24 27 88.8


line stmt bran cond sub pod time code
1             package Config::JSON;
2             $Config::JSON::VERSION = '1.5201';
3 5     5   109552 use strict;
  5         10  
  5         211  
4 5     5   2418 use Moo;
  5         59200  
  5         472  
5 5     5   6220 use File::Spec;
  5         10  
  5         113  
6 5     5   2790 use JSON 2.0;
  5         39524  
  5         29  
7 5     5   694 use List::Util;
  5         10  
  5         342  
8              
9 5     5   22 use constant FILE_HEADER => "# config-file-type: JSON 1\n";
  5         5  
  5         4486  
10              
11             #-------------------------------------------------------------------
12             has config => (
13             is => 'rw',
14             default => sub {{}},
15             );
16              
17             #-------------------------------------------------------------------
18             sub getFilePath {
19 0     0     my $self = shift;
20 0           return $self->pathToFile;
21             }
22              
23             #-------------------------------------------------------------------
24             has pathToFile => (
25             is => 'ro',
26             required => 1,
27             trigger => sub {
28             my ($self, $pathToFile, $old) = @_;
29             if (open(my $FILE, "<", $pathToFile)) {
30             # slurp
31             local $/ = undef;
32             my $json = <$FILE>;
33             close($FILE);
34             my $conf = eval { JSON->new->relaxed->utf8->decode($json); };
35             confess "Couldn't parse JSON in config file '$pathToFile'\n" unless ref $conf;
36             $self->config($conf);
37            
38             # process includes
39             my @includes = map { glob $_ } @{ $self->get('includes') || [] };
40             my @loadedIncludes;
41             foreach my $include (@includes) {
42             push @loadedIncludes, __PACKAGE__->new(pathToFile=>$include, isInclude=>1);
43             }
44             $self->includes(\@loadedIncludes);
45             }
46             else {
47             confess "Cannot read config file: ".$pathToFile;
48             }
49             },
50             );
51              
52             #-------------------------------------------------------------------
53             has isInclude => (
54             is => 'ro',
55             default => sub {0},
56             );
57              
58             #-------------------------------------------------------------------
59             has includes => (
60             is => 'rw',
61             default => sub {[]},
62             );
63              
64             #-------------------------------------------------------------------
65             sub getIncludes {
66             my $self = shift;
67             return $self->includes;
68             }
69              
70             #-------------------------------------------------------------------
71             around BUILDARGS => sub {
72             my $orig = shift;
73             my $class = shift;
74             if ( @_ == 1 && ! ref $_[0] ) {
75             return $class->$orig(pathToFile => $_[0]);
76             }
77             else {
78             return $class->$orig(@_);
79             }
80             };
81              
82             #-------------------------------------------------------------------
83             sub addToArray {
84             my ($self, $property, $value) = @_;
85             my $array = $self->get($property);
86             unless (defined List::Util::first { $value eq $_ } @{$array}) { # check if it already exists
87             # add it
88             push(@{$array}, $value);
89             $self->set($property, $array);
90             }
91             }
92              
93             #-------------------------------------------------------------------
94             sub addToArrayAfter {
95             my ($self, $property, $afterValue, $value) = @_;
96             my $array = $self->get($property);
97             unless (defined List::Util::first { $value eq $_ } @{ $array }) { # check if it already exists
98             my $idx = 0;
99             for (; $idx < $#{ $array }; $idx++) {
100             if ($array->[$idx] eq $afterValue) {
101             last;
102             }
103             }
104             splice @{ $array }, $idx + 1, 0, $value;
105             $self->set($property, $array);
106             }
107             }
108              
109             #-------------------------------------------------------------------
110             sub addToArrayBefore {
111             my ($self, $property, $beforeValue, $value) = @_;
112             my $array = $self->get($property);
113             unless (defined List::Util::first { $value eq $_ } @{ $array }) { # check if it already exists
114             my $idx = $#{ $array };
115             for (; $idx > 0; $idx--) {
116             if ($array->[$idx] eq $beforeValue) {
117             last;
118             }
119             }
120             splice @{ $array }, $idx , 0, $value;
121             $self->set($property, $array);
122             }
123             }
124              
125             #-------------------------------------------------------------------
126             sub addToHash {
127             my ($self, $property, $key, $value) = @_;
128             $self->set($property."/".$key, $value);
129             }
130              
131             #-------------------------------------------------------------------
132             sub create {
133             my ($class, $filename) = @_;
134             if (open(my $FILE,">",$filename)) {
135             print $FILE FILE_HEADER."\n{ }\n";
136             close($FILE);
137             }
138             else {
139             warn "Can't write to config file ".$filename;
140             }
141             return $class->new(pathToFile=>$filename);
142             }
143              
144             #-------------------------------------------------------------------
145             sub delete {
146             my ($self, $param) = @_;
147            
148             # inform the includes
149             foreach my $include (@{$self->includes}) {
150             $include->delete($param);
151             }
152            
153             # find the directive
154             my $directive = $self->config;
155             my @parts = $self->splitKeyParts($param);
156             my $lastPart = pop @parts;
157             foreach my $part (@parts) {
158             $directive = $directive->{$part};
159             }
160            
161             # only delete it if it exists
162             if (exists $directive->{$lastPart}) {
163             delete $directive->{$lastPart};
164             $self->write;
165             }
166             }
167              
168             #-------------------------------------------------------------------
169             sub deleteFromArray {
170             my ($self, $property, $value) = @_;
171             my $array = $self->get($property);
172             for (my $i = 0; $i < scalar(@{$array}); $i++) {
173             if ($array->[$i] eq $value) {
174             splice(@{$array}, $i, 1);
175             last;
176             }
177             }
178             $self->set($property, $array);
179             }
180              
181             #-------------------------------------------------------------------
182             sub deleteFromHash {
183             my ($self, $property, $key) = @_;
184             $self->delete($property."/".$key);
185             }
186              
187             #-------------------------------------------------------------------
188             sub get {
189             my ($self, $property) = @_;
190              
191             # they want a specific property
192             if (defined $property) {
193              
194             # look in this config
195             my $value = $self->config;
196             foreach my $part ($self->splitKeyParts($property)) {
197             $value = eval{$value->{$part}};
198             if ($@) {
199             confess "Can't access $property. $@";
200             }
201             }
202             return $value if (defined $value);
203              
204             # look through includes
205             foreach my $include (@{$self->includes}) {
206             my $value = $include->get($property);
207             return $value if (defined $value);
208             }
209              
210             # didn't find it
211             return undef;
212             }
213            
214             # they want the whole properties list
215             my %whole = ();
216             foreach my $include (@{$self->includes}) {
217             %whole = (%whole, %{$include->get});
218             }
219             %whole = (%whole, %{$self->config});
220             return \%whole;
221             }
222              
223             #-------------------------------------------------------------------
224             sub getFilename {
225             my $self = shift;
226             my @path = split "/", $self->pathToFile;
227             return pop @path;
228             }
229              
230             #-------------------------------------------------------------------
231             sub set {
232             my ($self, $property, $value) = @_;
233              
234             # see if the directive exists in this config
235             my $directive = $self->config;
236             my @parts = $self->splitKeyParts($property);
237             my $numParts = scalar @parts;
238             for (my $i=0; $i < $numParts; $i++) {
239             my $part = $parts[$i];
240             if (exists $directive->{$part}) { # exists so we continue
241             if ($i == $numParts - 1) { # we're on the last part
242             $directive->{$part} = $value;
243             $self->write;
244             return 1;
245             }
246             else {
247             $directive = $directive->{$part};
248             }
249             }
250             else { # doesn't exist so we quit
251             last;
252             }
253             }
254              
255             # see if any of the includes have this directive
256             foreach my $include (@{$self->includes}) {
257             my $found = $include->set($property, $value);
258             return 1 if ($found);
259             }
260              
261             # let's create the directive new in this config if it's not an include
262             unless ($self->isInclude) {
263             $directive = $self->config;
264             my $lastPart = pop @parts;
265             foreach my $part (@parts) {
266             unless (exists $directive->{$part}) {
267             $directive->{$part} = {};
268             }
269             $directive = $directive->{$part};
270             }
271             $directive->{$lastPart} = $value;
272             $self->write;
273             return 1;
274             }
275              
276             # didn't find a place to write it
277             return 0;
278             }
279              
280             #-------------------------------------------------------------------
281             sub splitKeyParts {
282             my ($self, $key) = @_;
283             my @parts = split /(?
284             map {s{\\\/}{/}} @parts;
285             return @parts;
286             }
287              
288             #-------------------------------------------------------------------
289             sub write {
290             my $self = shift;
291             my $realfile = $self->pathToFile;
292              
293             # convert data to json
294             my $json = JSON->new->pretty->utf8->canonical->encode($self->config);
295              
296             my $to_write = FILE_HEADER . "\n" . $json;
297             my $needed_bytes = length $to_write;
298              
299             # open as read/write
300             open my $fh, '+<:raw', $realfile or confess "Unable to open $realfile for write: $!";
301             my $current_bytes = (stat $fh)[7];
302             # shrink file if needed
303             if ($needed_bytes < $current_bytes) {
304             truncate $fh, $needed_bytes;
305             }
306             # make sure we can expand the file to the needed size before we overwrite it
307             elsif ($needed_bytes > $current_bytes) {
308             my $padding = q{ } x ($needed_bytes - $current_bytes);
309             sysseek $fh, 0, 2;
310             if (! syswrite $fh, $padding) {
311             sysseek $fh, 0, 0;
312             truncate $fh, $current_bytes;
313             close $fh;
314             confess "Unable to expand $realfile: $!";
315             }
316             sysseek $fh, 0, 0;
317             seek $fh, 0, 0;
318             }
319             print {$fh} $to_write;
320             close $fh;
321              
322             return 1;
323             }
324              
325              
326             =head1 NAME
327              
328             Config::JSON - A JSON based config file system.
329              
330             =head1 VERSION
331              
332             version 1.5201
333              
334             =head1 SYNOPSIS
335              
336             use Config::JSON;
337              
338             my $config = Config::JSON->create($pathToFile);
339             my $config = Config::JSON->new($pathToFile);
340             my $config = Config::JSON->new(pathToFile=>$pathToFile);
341              
342             my $element = $config->get($directive);
343              
344             $config->set($directive,$value);
345              
346             $config->delete($directive);
347             $config->deleteFromHash($directive, $key);
348             $config->deleteFromArray($directive, $value);
349              
350             $config->addToHash($directive, $key, $value);
351             $config->addToArray($directive, $value);
352              
353             my $path = $config->pathToFile;
354             my $filename = $config->getFilename;
355              
356             =head2 Example Config File
357              
358             # config-file-type: JSON 1
359             {
360             "dsn" : "DBI:mysql:test",
361             "user" : "tester",
362             "password" : "xxxxxx",
363              
364             # some colors to choose from
365             "colors" : [ "red", "green", "blue" ],
366              
367             # some statistics
368             "stats" : {
369             "health" : 32,
370             "vitality" : 11
371             },
372              
373             # including another file
374             "includes" : ["macros.conf"]
375             }
376              
377              
378             =head1 DESCRIPTION
379              
380             This package parses the config files written in JSON. It also does some non-JSON stuff, like allowing for comments in the files.
381              
382             If you want to see it in action, it is used as the config file system in WebGUI L.
383              
384              
385             =head2 Why?
386              
387             Why build yet another config file system? Well there are a number
388             of reasons: We used to use other config file parsers, but we kept
389             running into limitations. We already use JSON in our app, so using
390             JSON to store config files means using less memory because we already
391             have the JSON parser in memory. In addition, with JSON we can have
392             any number of hierarchcal data structures represented in the config
393             file, whereas most config files will give you only one level of
394             hierarchy, if any at all. JSON parses faster than XML and YAML.
395             JSON is easier to read and edit than XML. Many other config file
396             systems allow you to read a config file, but they don't provide any
397             mechanism or utilities to write back to it. JSON is taint safe.
398             JSON is easily parsed by languages other than Perl when we need to
399             do that.
400              
401              
402             =head2 Multi-level Directives
403              
404             You may of course access a directive called "foo", but since the config is basically a hash you can traverse
405             multiple elements of the hash when specifying a directive name by simply delimiting each level with a slash, like
406             "foo/bar". For example you may:
407              
408             my $vitality = $config->get("stats/vitality");
409             $config->set("stats/vitality", 15);
410              
411             You may do this wherever you specify a directive name.
412              
413              
414             =head2 Comments
415              
416             You can put comments in the config file as long as # is the first non-space character on the line. However, if you use this API to write to the config file, your comments will be eliminated.
417              
418              
419             =head2 Includes
420              
421             There is a special directive called "includes", which is an array of include files that may be brought in to
422             the config. Even the files you include can have an "includes" directive, so you can do hierarchical includes.
423              
424             Any directive in the main file will take precedence over the directives in the includes. Likewise the files
425             listed first in the "includes" directive will have precedence over the files that come after it. When writing
426             to the files, the same precedence is followed.
427              
428             If you're setting a new directive that doesn't currently exist, it will only be written to the main file.
429              
430             If a directive is deleted, it will be deleted from all files, including the includes.
431              
432             =head1 INTERFACE
433              
434             =head2 addToArray ( directive, value )
435              
436             Adds a value to an array directive in the config file.
437              
438             =head3 directive
439              
440             The name of the array.
441              
442             =head3 value
443              
444             The value to add.
445              
446             =head2 addToArrayBefore ( directive, insertBefore, value )
447              
448             Inserts a value into an array immediately before another item. If
449             that item can't be found, inserts at the beginning on the array.
450              
451             =head3 directive
452              
453             The name of the array.
454              
455             =head3 insertBefore
456              
457             The value to search for and base the positioning on.
458              
459             =head3 value
460              
461             The value to insert.
462              
463              
464             =head2 addToArrayAfter ( directive, insertAfter, value )
465              
466             Inserts a value into an array immediately after another item. If
467             that item can't be found, inserts at the end on the array.
468              
469             =head3 directive
470              
471             The name of the array.
472              
473             =head3 insertAfter
474              
475             The value to search for and base the positioning on.
476              
477             =head3 value
478              
479             The value to insert.
480              
481              
482              
483             =head2 addToHash ( directive, key, value )
484              
485             Adds a value to a hash directive in the config file. B This is really the same as
486             $config->set("directive/key", $value);
487              
488             =head3 directive
489              
490             The name of the hash.
491              
492             =head3 key
493              
494             The key to add.
495              
496             =head3 value
497              
498             The value to add.
499              
500              
501             =head2 create ( pathToFile )
502              
503             Constructor. Creates a new empty config file.
504              
505             =head3 pathToFile
506              
507             The path and filename of the file to create.
508              
509              
510              
511             =head2 delete ( directive )
512              
513             Deletes a key from the config file.
514              
515             =head3 directive
516              
517             The name of the directive to delete.
518              
519              
520             =head2 deleteFromArray ( directive, value )
521              
522             Deletes a value from an array directive in the config file.
523              
524             =head3 directive
525              
526             The name of the array.
527              
528             =head3 value
529              
530             The value to delete.
531              
532              
533              
534             =head2 deleteFromHash ( directive, key )
535              
536             Delete a key from a hash directive in the config file. B This is really just the same as doing
537             $config->delete("directive/key");
538              
539             =head3 directive
540              
541             The name of the hash.
542              
543             =head3 key
544              
545             The key to delete.
546              
547              
548              
549             =head2 get ( directive )
550              
551             Returns the value of a particular directive from the config file.
552              
553             =head3 directive
554              
555             The name of the directive to return.
556              
557              
558              
559             =head2 getFilename ( )
560              
561             Returns the filename for this config.
562              
563              
564              
565             =head2 pathToFile ( )
566              
567             Returns the filename and path for this config. May also be called as C for backward campatibility sake.
568              
569              
570              
571             =head2 includes ( )
572              
573             Returns an array reference of Config::JSON objects that are files included by this config. May also be called as C for backward compatibility sake.
574              
575              
576             =head2 new ( pathToFile )
577              
578             Constructor. Builds an object around a config file.
579              
580             =head3 pathToFile
581              
582             A string representing a path such as "/etc/my-cool-config.conf".
583              
584              
585              
586             =head2 set ( directive, value )
587              
588             Creates a new or updates an existing directive in the config file.
589              
590             =head3 directive
591              
592             A directive name.
593              
594             =head3 value
595              
596             The value to set the paraemter to. Can be a scalar, hash reference, or array reference.
597              
598              
599              
600             =head2 splitKeyParts ( key )
601              
602             Returns an array of key parts.
603              
604             =head3 key
605              
606             A key string. Could be 'foo' (simple key), 'foo/bar' (a multilevel key referring to the bar key as a child of foo), or 'foo\/bar' (a simple key that contains a slash in the key). Don't forget to double escape in your perl code if you have a slash in your key parts like this:
607              
608             $config->get('foo\\/bar');
609              
610             =cut
611              
612              
613              
614             =head2 write ( )
615              
616             Writes the file to the filesystem. Normally you'd never need to call this as it's called automatically by the other methods when a change occurs.
617              
618              
619             =head1 DIAGNOSTICS
620              
621             =over
622              
623             =item C<< Couldn't parse JSON in config file >>
624              
625             This means that the config file does not appear to be formatted properly as a JSON file. Common mistakes are missing commas or trailing commas on the end of a list.
626              
627             =item C<< Cannot read config file >>
628              
629             We couldn't read the config file. This usually means that the path specified in the constructor is incorrect.
630              
631             =item C<< Can't write to config file >>
632              
633             We couldn't write to the config file. This usually means that the file system is full, or the that the file is write protected.
634              
635             =back
636              
637             =head1 PREREQS
638              
639             L L L L L
640              
641             =head1 SUPPORT
642              
643             =over
644              
645             =item Repository
646              
647             L
648              
649             =item Bug Reports
650              
651             L
652              
653             =back
654              
655             =head1 AUTHOR
656              
657             JT Smith
658              
659             =head1 LEGAL
660              
661             Config::JSON is Copyright 2009 Plain Black Corporation (L) and is licensed under the same terms as Perl itself.
662              
663             =cut
664              
665             1;