Girocco/ConfigUtil.pm

   1 package Girocco::ConfigUtil;
   2
   3 use 5.008;
   4 use strict;
   5 use warnings;
   6
   7 use Encode;
   8
   9 BEGIN {
  10         use base qw(Exporter);
  11         our @EXPORT = qw(to_utf8 read_config_file read_config_file_hash git_bool);
  12 }
  13
  14 my $encoder;
  15 BEGIN {
  16         $encoder = Encode::find_encoding('Windows-1252') ||
  17                    Encode::find_encoding('ISO-8859-1') or
  18                    die "failed to load ISO-8859-1 encoder\n";
  19 }
  20
  21 sub to_utf8($;$) {
  22         my ($str, $encode) = @_;
  23         return undef unless defined $str;
  24         my $ans;
  25         if (Encode::is_utf8($str) || utf8::decode($str)) {
  26                 $ans = $str;
  27         } else {
  28                 $ans = $encoder->decode($str, Encode::FB_DEFAULT);
  29         }
  30         utf8::encode($ans) if $encode;
  31         return $ans;
  32 }
  33
  34 my $cf_unesc;
  35 BEGIN {
  36         my %escvals = (
  37                 b    => "\b",
  38                 t    => "\t",
  39                 n    => "\n",
  40                 '"'  => '"',
  41                 '\\' => '\\'
  42         );
  43         $cf_unesc = sub {
  44                 $_[0] =~ s/\\([btn\042\\])/$escvals{$1}/g;
  45                 $_[0];
  46         };
  47 }
  48
  49 # mimics Git's config.c git_parse_source function behavior
  50 # returns array of arrayref of key and value
  51 # except that valueless booleans have a value of undef
  52 sub read_config_file {
  53         local $_;
  54         my ($fn, $warn) = @_;
  55         my $li = 0;
  56         my $section = "";
  57         my @vals = ();
  58         open my $fh, '<', $fn or
  59                 $warn && warn("could not open \"$fn\": $!\n"), return(undef);
  60         binmode($fh);
  61         my $bad = sub {
  62                 close $fh;
  63                 warn "bad config line $li in file $fn\n" if $warn;
  64                 return undef;
  65         };
  66         while (<$fh>) {
  67                 ++$li;
  68                 s/(?:\r\n|\n)$//;
  69                 $_ = to_utf8($_);
  70                 s/^\x{feff}// if $li == 1;
  71                 utf8::encode($_);
  72                 if (/^\s*\[/gc) {
  73                         if (/\G([.a-zA-Z0-9-]+)\]/gc) {
  74                                 $section = lc($1) . ".";
  75                         } elsif (/\G([.a-zA-Z0-9-]*)\s+"((?:[^\042\\\n]|\\.)*)"\]/gc) {
  76                                 $section = lc($1) . "." .
  77                                         &{sub{my $x=shift; $x =~ s/\\(.)/$1/g; $x}}($2) . ".";
  78                         } else {
  79                                 return &$bad;
  80                         }
  81                 }
  82                 /\G\s+/gc;
  83                 next if /\G(?:[;#]|$)/;
  84                 if (/\G([a-zA-Z][a-zA-Z0-9-]*)[ \t]*/gc) {
  85                         my $k = $section . lc($1);
  86                         my $v;
  87                         if (/\G$/) {
  88                                 $v = undef;
  89                         } elsif (/\G=\s*/gc) {
  90                                 $v = "";
  91                                 my $qt = 0;
  92                                 {
  93                                         if (/\G$/) {
  94                                                 last if !$qt;
  95                                                 return &$bad;
  96                                         }
  97                                         if (!$qt && /\G((?:[^"\\\n;#]|\\[btn"\\])+)/gc) {
  98                                                 my $a = $1;
  99                                                 if (/\G[;#]/) {
 100                                                         $_ = "";
 101                                                         $a =~ s/\s+$//;
 102                                                 }
 103                                                 $a =~ s/\s/ /g;
 104                                                 $v .= &$cf_unesc($a);
 105                                         } elsif ($qt && /\G((?:[^"\\\n]|\\[btn"\\])+)/gc) {
 106                                                 my $a = $1;
 107                                                 $v .= &$cf_unesc($a);
 108                                         } elsif (/\G\042/gc) {
 109                                                 $qt = !$qt;
 110                                         } elsif (!$qt && /\G[;#]/gc) {
 111                                                 $_ = "";
 112                                         } elsif (/\G\\$/) {
 113                                                 $_ = <$fh>;
 114                                                 if (defined($_)) {
 115                                                         ++$li;
 116                                                         s/(?:\r\n|\n)$//;
 117                                                         $_ = to_utf8($_, 1);
 118                                                         /^\s+/gc unless $v ne "" || $qt;
 119                                                 } else {
 120                                                         $_ = "";
 121                                                 }
 122                                         } else {
 123                                                 return &$bad;
 124                                         }
 125                                         redo;
 126                                 }
 127                         } else {
 128                                 return &$bad;
 129                         }
 130                         push(@vals, [$k, $v]);
 131                 } else {
 132                         return &$bad;
 133                 }
 134         }
 135         close $fh;
 136         return \@vals;
 137 }
 138
 139 # Same as read_config_file except that a hashref is returned and
 140 # subsequent same-key-name values replace earlier ones.
 141 # Also valueless booleans are given the value 1
 142 sub read_config_file_hash {
 143         my $result = read_config_file(@_);
 144         return undef unless defined($result);
 145         my %config = map {($$_[0], defined($$_[1])?$$_[1]:1)} @$result;
 146         return \%config;
 147 }
 148
 149 # Returns 0 for false, 1 for true, undef for unrecognized or undef
 150 # Unless the optional second argument is true in which case undef returns 1
 151 sub git_bool {
 152         defined($_[0]) or return $_[1] ? 1 : undef;
 153         my $v = lc($_[0]);
 154         return 0 if $v eq 'false' || $v eq 'off' || $v eq 'no' || $v eq '' || $v =~ /^[-+]?0+$/;
 155         return 1 if $v eq 'true' || $v eq 'on' || $v eq 'yes' || $v =~ /^[-+]?0*[1-9][0-9]*$/;
 156         return undef;
 157 }
 158
 159 1;