File Coverage

blib/lib/Config/Yacp.pm

Criterion	Covered	Total	%
statement	130	148	87.8
branch	43	78	55.1
condition	0	2	0.0
subroutine	25	27	92.5
pod	0	14	0.0
total	198	269	73.6

package Config::Yacp;
{
  use Object::InsideOut;
  use Parse::RecDescent;
  use Fcntl qw/:flock/;
  use Carp;
  use strict;
  use Data::Dumper;
  use vars qw($VERSION $grammar $CONFIG);

  $VERSION='2.00';
  BEGIN{ $::RD_AUTOACTION=q{ [@item[1..$#item]] }; }

  # Define the grammar
  $grammar = q(
                 file: section(s)
                 section: header pair(s?)
                 header:  /\[(\w+)\]/ { $1 }
                 pair:    /(\w+)\s?=\s?(\w+)?(\s+[;#][\s\w]+)?\n/
                 {
                   if(!defined $3){
                     [$1,$2];
                   }else{
                     [$1,$2,$3];
                   }
                 }
              );
  my @FileName      :Field('Standard'=>'FileName','Type'=>'LIST');
  my @CommentMarker :Field('Standard'=>'CommentMarker','Type'=>'LIST');

  my %init_args :InitArgs=(
    'FileName'=>{
        'Regex' => qr/^FileName$/i,
	'Mandatory' => 1,
    },
    'CommentMarker'=>{
        'Regex' => qr/^CommentMarker$/i,
	'Default' => '#',
    }
  );

  sub _init :Init{
    my ($self,$args)=@_;
    if(exists($args->{'FileName'})){
      $self->set(\@FileName,$args->{'FileName'});
    }
    if(exists($args->{'CommentMarker'})){
      $self->set(\@CommentMarker,$args->{'CommentMarker'});
    }
    my $cm=$self->get_CommentMarker;
    if($cm!~/[#;]/){
      croak "Incorrect Comment Marker detected. Use either # or ; to mark comments";
    }
    my $parser = Parse::RecDescent->new($grammar);
    my $file=$self->get_FileName;
    my $ini;
    {
      no strict 'subs';
      $/=undef;
      open(FILE,"$file")||croak "Can't open $file: $!";
      flock(FILE,LOCK_SH) or die "Unable to obtain a file lock: $!\n";
      $ini=;
      flock(FILE,LOCK_UN);
      close FILE;
    }

    my $tree = $parser->file($ini);
    $CONFIG = deparse($tree);
  }

  sub retrieve_sections{
    my @sections = sort keys %$CONFIG;
    return @sections;
  }

  sub retrieve_parameters{
    my ($self,$section)=@_;
    croak "No section given" if !defined $section;
    croak "Non-existent section given" if !exists $CONFIG->{$section};
    my @params = sort keys %{$CONFIG->{$section}};
    return @params;
  }

  sub retrieve_value{
    my($self,$section,$parameter)=@_;
    croak "Missing arguments" if scalar @_ < 3;
    croak "Non-existent section given" if !exists $CONFIG->{$section};
    croak "Non-existent parameter given" if !exists $CONFIG->{$section}->{$parameter};
    my $value=$CONFIG->{$section}->{$parameter}->[0];
    return $value;
  }

  sub change_value{
    my($self,$section,$parameter,$value)=@_;
    croak "Missing arguments" if scalar @_ < 4;
    croak "Non-existent section given" if !exists $CONFIG->{$section};
    croak "Non-existent parameter given" if !exists $CONFIG->{$section}->{$parameter};
    $CONFIG->{$section}->{$parameter}->[0]=$value;
  }

  sub retrieve_comment{
    my($self,$section,$parameter)=@_;
    croak"Missing arguments" if scalar @_ < 3;
    croak"Invalid section argument" if !exists $CONFIG->{$section};
    croak"Invalid parameter argument" if !exists $CONFIG->{$section}->{$parameter};
    if (!defined $CONFIG->{$section}->{$parameter}->[1]){
      local $SIG{__WARN__}=sub{ $@=shift; };
      carp"No comment available for this parameter";
    }else{
      my $comment=$CONFIG->{$section}->{$parameter}->[1];
      return $comment;
    }
  }

  sub add_section{
    my ($self,$section)=@_;
    croak"Missing arguments" if scalar @_ < 2;
    croak"Section exists!" if exists $CONFIG->{$section};
    $CONFIG->{$section}=undef;
  }

  sub add_parameter{
    my ($self,$section,$para,$value,$comment)=@_;
    croak"Missing arguments" if scalar @_ < 4;
    if(!exists $CONFIG->{$section}){
      $self->add_section($section);
    }
    croak"Parameter exists" if exists $CONFIG->{$section}->{$para};
    $CONFIG->{$section}->{$para}=[$value];
    if(defined $comment){ push @{$CONFIG->{$section}->{$para}},$comment; }
  }

  sub add_comment{
    my ($self,$section,$para,$comment)=@_;
    croak"Missing arguments" if scalar @_ < 4;
    croak"Non-Existent section" if !exists $CONFIG->{$section};
    croak"Non-Existent parameter" if !exists $CONFIG->{$section}->{$para};
    $CONFIG->{$section}->{$para}->[1]=$comment;
  }

  sub display_config{
    print Dumper($CONFIG);
  }

  sub delete_section{
    my ($self,$section)=@_;
    croak"Missing arguments" if scalar @_ < 2;
    croak"Non-Existent section" if !exists $CONFIG->{$section};
    delete $CONFIG->{$section};
  }

  sub delete_parameter{
    my ($self,$section,$para)=@_;
    croak"Missing arguments" if scalar @_ < 3;
    croak"Non-Existent section" if !exists $CONFIG->{$section};
    croak"Non-Existent parameter" if !exists $CONFIG->{$section}->{$para};
    delete $CONFIG->{$section}->{$para};
  }

  sub delete_comment{
    my ($self,$section,$para)=@_;
    croak"Missing arguments" if scalar @_ < 3;
    croak"Non-Existent section" if !exists $CONFIG->{$section};
    croak"Non-Existent parameter" if !exists $CONFIG->{$section}->{$para};
    if(defined $CONFIG->{$section}->{$para}->[1]){
      pop @{$CONFIG->{$section}->{$para}};
    }else{
      local $SIG{__WARN__}=sub{ $@=shift; };
      carp"No comment located for that parameter";
    }
  }

  sub save{
    no strict "refs";
    my $self=shift;
    my $file=$self->get_FileName;
    my $CM=$self->get_CommentMarker;
    open FH,">$file"||die"Unable to open $file: $!\n";
    flock(FH,LOCK_EX) or die "Unable to obtain file lock: $!\n";
    foreach my $section(sort keys %{$CONFIG}){
      print FH "[$section]\n";
      foreach my $para(sort keys %{$CONFIG->{$section}}){
        print FH "$para = $CONFIG->{$section}{$para}[0]";
	if(defined $CONFIG->{$section}{$para}[1]){
	  print FH "    $CM$CONFIG->{$section}{$para}[1]\n";
	}else{
	  print FH "\n";
	}
      }
      print FH "\n";
    }
    flock(FH,LOCK_UN) or die"Unable to unlock file: $!\n";
    close FH;
  }

  sub deparse{
    my $tree=shift;
    my $deparsed={};
      for my $aref(@$tree){
        for my $sec(@$aref){
          my $hash=$deparsed->{$sec->[0]}={};
          for my $aref(@{$sec->[1]}){
	    $hash->{$aref->[0]}=[$aref->[1]];
	    if(my $cmmnt=$aref->[2]){
	      $cmmnt=~s/^\s+[#;]//;
              push @{$hash->{$aref->[0]}},$cmmnt;
            }
          }
        }
      }
    return $deparsed;
  }
1;
}
__END__