File Coverage

blib/lib/Crypt/SecretBuffer/INI.pm

Criterion	Covered	Total	%
statement	104	126	82.5
branch	73	102	71.5
condition	17	23	73.9
subroutine	16	16	100.0
pod	10	10	100.0
total	220	277	79.4

package Crypt::SecretBuffer::INI;
# VERSION
# ABSTRACT: Parse INI format from a SecretBuffer
$Crypt::SecretBuffer::INI::VERSION = '0.022';
use strict;
use warnings;
use Carp;
use Crypt::SecretBuffer qw/ secret MATCH_NEGATE MATCH_MULTI ISO8859_1 /;


sub new {
   my $self= bless {
         comment_delim => qr/[;#]/,
         key_value_delim => '=',
         section_delim => undef,
         trim_chars => qr/[ \t]+/,
         inline_comments => !!0,
         bare_keys => !!0,
         field_config => [],
      }, shift;
   while (@_) {
      my ($attr, $val)= splice(@_, 0, 2);
      $self->$attr($val);
   }
   $self;
}


sub key_value_delim {
   @_ > 1? ($_[0]{key_value_delim}= $_[1]) : $_[0]{key_value_delim}
}
sub bare_keys {
   @_ > 1? ($_[0]{bare_keys}= !!$_[1]) : $_[0]{bare_keys}
}
sub trim_chars {
   @_ > 1? ($_[0]{trim_chars}= $_[1]) : $_[0]{trim_chars}
}
sub section_delim {
   @_ > 1? ($_[0]{section_delim}= $_[1]) : $_[0]{section_delim}
}
sub comment_delim {
   @_ > 1? ($_[0]{comment_delim}= $_[1]) : $_[0]{comment_delim}
}
sub inline_comments {
   @_ > 1? ($_[0]{inline_comments}= $_[1]) : $_[0]{inline_comments}
}


sub field_config {
   @_ > 1? ($_[0]{field_config}= _coerce_field_rules($_[1])) : $_[0]{field_config}
}

sub _coerce_field_rules {
   my $rule_spec= shift;
   ref $rule_spec eq 'ARRAY'
      or croak "field rules must be an arrayref";
   my @rules;
   for (my $i= 0; $i < @$rule_spec; $i++) {
      my $rule= $rule_spec->[$i];
      # scalar or regexpref are treated as keys
      if (!ref $rule or ref $rule eq 'Regexp') {
         my $v= $rule_spec->[++$i];
         if (ref $v eq 'ARRAY') {
            $rule= { section => $rule, rules => $v };
         } elsif (ref $v eq 'HASH') {
            $rule= { key => $rule, %$v };
         } elsif (defined $v) {
            $rule= { key => $rule, flags => $v };
         } else {
            croak "Value paired with '$rule' should be arrayref, hashref, or scalar";
         }
      }
      # hashrefs remain as-is
      elsif ($rule ne 'HASH') {
         croak "Expected scalar, Regexp, or hashref at '$rule'";
      }
      $rule->{rules}= _coerce_field_rules($rule->{rules})
         if ref $rule->{rules} eq 'ARRAY';
      push @rules, $rule;
   }
   return \@rules;
}
sub _find_field_rule {
   my ($self, $rules, $section, $key)= @_;
   for (@$rules) {
      if (defined $_->{key}) {
         # It's a rule for keys.  Return it if the key matches.
         return $_ if ref $_->{key} eq 'Regexp'? $key =~ $_->{key} : $key eq $_->{key};
      }
      elsif (defined $_->{section} && defined $section) {
         # It's a rule for sections.  Matching the section name is a bit complex because
         # it can match in ful, or in part, and if the user defines a section hierarchy
         # separator then we need to determine how much of the section name to pass to the
         # recursive call.
         my $sep= $self->section_delim;
         my $key_rule;
         if (ref $_->{section} eq 'Regexp') {
            if ($section =~ $_->{section}) {
               my $subsection;
               if (defined $sep) {
                  # This gets complicated.  The regex matched the whole section name, but the
                  # user maybe intended it to only match some upper portion of the section
                  # hierarchy.
                  $sep= qr/\Q$sep\E/ unless ref $sep eq 'Regexp';
                  while ($section =~ /$sep/g) {
                     if (substr($section, 0, $-[0]) =~ $_->{section}) {
                        $subsection= substr($section, $+[0]);
                     }
                  }
                  my $rule= $self->_find_field_rule($_->{rules}, $section, $key);
               } else {
                  $subsection= $section;
               }
               $key_rule= $self->_find_field_rule($_->{rules}, $subsection, $key);
            }
         } elsif ($section eq $_->{section}) {
            $key_rule= $self->_find_field_rule($_->{rules}, undef, $key);
         } elsif (defined $sep
            && $_->{section} eq substr($section, 0, length $_->{section})
         ) {
            my ($remainder, $subsection)= split $sep, substr($section, length $_->{section}), 2;
            # It was only a match of a hierarchy if the separator matched immediately after
            # the length of $_->{section}.
            $key_rule= $self->_find_field_rule($_->{rules}, $subsection, $key)
               if !length $remainder;
         }
         return $key_rule if defined $key_rule;
      }
   }
   return undef;
}


sub parse_next {
   my ($self, $span)= @_;
   my ($trim_chars, $comment_delim)= ($self->trim_chars, $self->comment_delim);
   my %result;
   while ($span->len && !keys %result) {
      my $line= $span->parse(qr/[^\n]+/);
      if (!$span->parse("\n")) {
         $result{error}= 'No newline on end of file';
      }
      $line->rtrim("\r");
      if ($line->parse('[')) {
         my $header= $line->parse(qr/[^]]+/)->trim($trim_chars);
         if (!$line->parse(']')) {
            $result{error}= "Missing ']' in section header";
            $header->pos($header->pos-1);
            $result{context}= $header;
         } else {
            $result{section}= $header;
            $line->ltrim($trim_chars);
         }
      }
      elsif (!$line->starts_with($comment_delim)) {
         my $key= $line->parse($self->key_value_delim, MATCH_NEGATE|MATCH_MULTI);
         # Make sure key delimiter was found before comment, if inline_comments allowed
         if ($self->inline_comments && (my $comment_start= $key->scan($comment_delim))) {
            $key->lim($comment_start->pos);
            $line->pos($comment_start->pos);
         }
         if ($line->parse($self->key_value_delim)) {
            $result{key}= $key->trim($trim_chars);
            # TODO: handle optional quoting here
            if ($self->inline_comments) {
               $result{value}= $line->parse($comment_delim, MATCH_NEGATE|MATCH_MULTI)->trim($trim_chars);
            } else {
               $result{value}= $line->new->trim($trim_chars);
               $line->pos($line->lim);
            }
         } elsif ($self->bare_keys) {
            $result{key}= $key->trim($trim_chars);
         } else {
            $result{error}= 'Line lacks delimiter "'.$self->key_value_delim.'"';
            $result{context}= $key;
         }
      }
      if ($line->parse($comment_delim)) {
         $result{comment}= $line->trim($trim_chars);
      } elsif ($line->len) {
         $result{error}= 'extra text encountered before end of line';
      }
   }
   return keys %result? \%result : undef;
}


sub parse {
   my ($self, $buf_or_span)= @_;
   my $span= $buf_or_span->can('subspan')? $buf_or_span : $buf_or_span->span;
   my ($node, $section, $key, $value);
   my $sep= $self->section_delim;
   $sep= qr/\Q$sep\E/ if defined $sep && ref $sep ne 'Regexp';
   my $root= defined $sep? {} : [];
   while (my $tokens= $self->parse_next($span)) {
      croak $tokens->{error}
         if defined $tokens->{error};
      if (defined $tokens->{section}) {
         $tokens->{section}->copy_to($section= '');
         if (defined $sep) {
            $node= $root;
            for (split $sep, $section) {
               croak("conflict between section name and pre-existing key of parent section")
                  if defined $node->{$_} && ref $node->{$_} ne 'HASH';
               $node= ($node->{$_} ||= {});
            }
         } else {
            push @$root, $section, ($node= {});
         }
      }
      if (defined $tokens->{key}) {
         if (!defined $node) {
            if (defined $sep) {
               $node= $root;
            } else {
               push @$root, '', ($node= {});
            }
         }
         $tokens->{key}->copy_to($key= '');
         if (!$tokens->{value}) {
            $value= undef;
         } else {
            my $rule= $self->_find_field_rule($self->field_config, $section, $key);
            $tokens->{value}->encoding($rule->{encoding})
               if defined $rule->{encoding};
            if ($rule->{secret}) {
               $tokens->{value}->copy_to(($value= secret), encoding => ISO8859_1);
            } else {
               $tokens->{value}->copy_to($value= '');
            }
         }
         $node->{$key}= $value;
      }
   }
   return $root;
}

# avoid depending on namespace::clean
delete @{Crypt::SecretBuffer::INI::}{qw(
   carp confess croak secret MATCH_NEGATE MATCH_MULTI ISO8859_1
)};

1;

__END__