File Coverage

blib/lib/DB/Color/Config.pm
Criterion Covered Total %
statement 11 56 19.6
branch 3 38 7.8
condition 0 2 0.0
subroutine 4 9 44.4
pod 6 6 100.0
total 24 111 21.6


line stmt bran cond sub pod time code
1             package DB::Color::Config;
2              
3             # If you thought Config::Simple was small...
4              
5 1     1   5 use strict;
  1         2  
  1         75  
6             BEGIN {
7 1     1   36 require 5.004;
8 1         4 $DB::Color::Config::VERSION = '0.10';
9 1         886 $DB::Color::Config::errstr = '';
10             }
11              
12             # Create an empty object
13 0     0 1 0 sub new { bless {}, shift }
14              
15             # Create an object from a file
16             sub read {
17 1 50   1 1 7 my $class = ref $_[0] ? ref shift : shift;
18              
19             # Check the file
20 1 50       6 my $file = shift or return $class->_error( 'You did not specify a file name' );
21 1 50       30 return $class->_error( "File '$file' does not exist" ) unless -e $file;
22 0 0       0 return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
23 0 0       0 return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
24              
25             # Slurp in the file
26 0         0 local $/ = undef;
27 0 0       0 open( CFG, $file ) or return $class->_error( "Failed to open file '$file': $!" );
28 0         0 my $contents = ;
29 0         0 close( CFG );
30              
31 0         0 $class->read_string( $contents );
32             }
33              
34             # Create an object from a string
35             sub read_string {
36 0 0   0 1 0 my $class = ref $_[0] ? ref shift : shift;
37 0         0 my $self = bless {}, $class;
38 0 0       0 return undef unless defined $_[0];
39              
40             # Parse the file
41 0         0 my $ns = '_';
42 0         0 my $counter = 0;
43 0         0 foreach ( split /(?:\015{1,2}\012|\015|\012)/, shift ) {
44 0         0 $counter++;
45              
46             # Skip comments and empty lines
47 0 0       0 next if /^\s*(?:\#|\;|$)/;
48              
49             # Remove inline comments
50 0         0 s/\s\;\s.+$//g;
51              
52             # Handle section headers
53 0 0       0 if ( /^\s*\[\s*(.+?)\s*\]\s*$/ ) {
54             # Create the sub-hash if it doesn't exist.
55             # Without this sections without keys will not
56             # appear at all in the completed struct.
57 0   0     0 $self->{$ns = $1} ||= {};
58 0         0 next;
59             }
60              
61             # Handle properties
62 0 0       0 if ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) {
63 0         0 $self->{$ns}->{$1} = $2;
64 0         0 next;
65             }
66              
67 0         0 return $self->_error( "Syntax error at line $counter: '$_'" );
68             }
69              
70 0         0 $self;
71             }
72              
73             # Save an object to a file
74             sub write {
75 0     0 1 0 my $self = shift;
76 0 0       0 my $file = shift or return $self->_error(
77             'No file name provided'
78             );
79              
80             # Write it to the file
81 0         0 my $string = $self->write_string;
82 0 0       0 return undef unless defined $string;
83 0 0       0 open( CFG, '>' . $file ) or return $self->_error(
84             "Failed to open file '$file' for writing: $!"
85             );
86 0         0 print CFG $string;
87 0         0 close CFG;
88             }
89              
90             # Save an object to a string
91             sub write_string {
92 0     0 1 0 my $self = shift;
93              
94 0         0 my $contents = '';
95 0 0       0 foreach my $section ( sort { (($b eq '_') <=> ($a eq '_')) || ($a cmp $b) } keys %$self ) {
  0         0  
96             # Check for several known-bad situations with the section
97             # 1. Leading whitespace
98             # 2. Trailing whitespace
99             # 3. Newlines in section name
100 0 0       0 return $self->_error(
101             "Illegal whitespace in section name '$section'"
102             ) if $section =~ /(?:^\s|\n|\s$)/s;
103 0         0 my $block = $self->{$section};
104 0 0       0 $contents .= "\n" if length $contents;
105 0 0       0 $contents .= "[$section]\n" unless $section eq '_';
106 0         0 foreach my $property ( sort keys %$block ) {
107 0 0       0 return $self->_error(
108             "Illegal newlines in property '$section.$property'"
109             ) if $block->{$property} =~ /(?:\012|\015)/s;
110 0         0 $contents .= "$property=$block->{$property}\n";
111             }
112             }
113            
114 0         0 $contents;
115             }
116              
117             # Error handling
118 0     0 1 0 sub errstr { $DB::Color::Config::errstr }
119 1     1   3 sub _error { $DB::Color::Config::errstr = $_[1]; undef }
  1         5  
120              
121             1;
122              
123             __END__