Apache::Admin::Config - A module to read/write Apache like configuration files

    use Apache::Admin::Config;

    # Parse an apache configuration file

    my $conf = new Apache::Admin::Config "/path/to/config_file.conf"
        or die $Apache::Admin::Config::ERROR;

    my $directive = $conf->directive('documentroot');

    print $directive->name;   # "documentroot"
    print $directive->value;  # "/my/document/root"
    print $directive->type;   # "directive"

    $directive->isin($conf);  # true

    $directive->delete;

    # print the directive list

    foreach($conf->directive())
    {
        print $_->name, "\n";
    }

    # print the virtualhost list

    print $_->section('servername')->value(), "\n"
      foreach $conf->section(-name => "virtualhost");

    # add a directive in all virtualhosts

    foreach($conf->section(-name => "virtualhost"))
    {
        $_->add_directive(php_admin_value => 'open_basedir "/path"');
    }

    # Deleting all "AddType" directives

    $_->delete for $conf->directive("AddType");

    # saving changes in place

    $conf->save;

    $obj = new Apache::Admin::Config [/path/to/file|handle],
      [-indent => $integer], ['-create'], ['-no-comment-grouping'],
      ['-no-blank-grouping']

    $obj->save(['/path/to/file'|HANDLE], ['-reformat'])

    $conf->save(\*MYHANDLE) or die($conf->error());

    $obj->dump_raw

  $obj->dump_raw

    @result = $obj->select
    (
        [-type  => $type],
        [-name  => $name],
        [-value => $value],
        [-which => $index],
    );

    @directives    = $obj->select('directive');
    @sections_foo  = $obj->select('section', 'Foo');

    @directives = $obj->directive(args...)

    @sections = $obj->section(args...)

    @comments = $obj->comment(args...)

    @blanks = $obj->blank(args...)

  $conf->set_write_directive($code);

  $conf->set_write_directive(sub
  {
      my($self, $name, $value) = @_;
      return $self->indent . "$name $value\n";
  }

  $conf->set_write_section($code);

  $conf->set_write_section(sub
  {
      my($self, $name, $value) = @_;
      return $self->indent . "<$name $value>\n";
  }

  $conf->set_write_section_closing($code);

  $conf->set_write_section_closing(sub
  {
      my($self, $name) = @_;
      return $self->indent . "</$name>\n";
  }

  $conf->set_write_comment($code);

  $conf->set_write_comment(sub
  {
      my($self, $value) = @_;
      # handle comment grouping
      $value =~ s/\n/\n# /g;
      return $self->indent . join('#', split(/\n/, $value));
  }

  $conf->set_write_blank($code);

  $conf->set_write_blank(sub
  {
      my($self, $number) = @_;
      return $number x "\n";
  }

    $item = $obj->add
    (
        $type|$item, [$name], [$value],
        [-before => $target | -after => $target | '-ontop' | '-onbottom']
    );

    $item = $obj->add('section', foo => 'bar', -after => $conf_item_object);
    $item = $obj->add('comment', 'a simple comment', '-ontop');

    $section = $obj->add_section($name, $value)

    $directive = $obj->add_directive($name, $value)

    $comment = $obj->add_comment("string", [$group])

    $blank = $obj->add_blank([$group])

    $obj->set_value($newvalue)

    $obj->move
    (
        $dest_section,
        -before => target |
        -after => $target |
        '-ontop' |
        '-onbottom'
    )

    $item->copy
    (
        $dest_section,
        -before => target |
        -after => $target |
        '-ontop' |
        '-onbottom'
    )

  $clone = $item->clone();

    $boolean = $obj->($section_obj, ['-recursif'])

    <section target>
        <sub section>
            directive test
        </sub>
    </section>

    $test_directive->isin($target_section)              => return false
    $test_directive->isin($sub_section)                 => return true
    $test_directive->isin($target_section, '-recursif') => return true
    $target_section->isin($target_section)              => return true

  $boolean = $item->unlink();

  $boolean = $item->destroy();

    $booleen = $item->delete;

  #
  # Reindent configuration file properly
  #

  my $conf = Apache::Admin::Config
    (
     '/etc/apache/httpd.conf',
     -indent => 2
    );

  $conf->save('-reformat');

  #
  # Managing virtual-hosts:
  #

  my $conf = new Apache::Admin::Config "/etc/apache/httpd.conf";

  # adding a new virtual-host:
  my $vhost = $conf->add_section(VirtualHost=>'127.0.0.1');
  $vhost->add_directive(ServerAdmin=>'webmaster@localhost.localdomain');
  $vhost->add_directive(DocumentRoot=>'/usr/share/www');
  $vhost->add_directive(ServerName=>'www.localhost.localdomain');
  $vhost->add_directive(ErrorLog=>'/var/log/apache/www-error.log');
  my $location = $vhost->add_section(Location=>'/admin');
  $location->add_directive(AuthType=>'basic');
  $location->add_directive(Require=>'group admin');
  $conf->save;

  # selecting a virtual-host:
  my $vhost;
  foreach my $vh (@{$conf->section('VirtualHost')})
  {
      if($vh->directive('ServerName')->value eq 'www.localhost.localdomain')
      {
          $vhost = $vh;
          last;
      }
  }

  #
  # Suppress all comments in the file
  # 

  sub delete_comments
  {
      foreach(shift->comment)
      {
          $_->delete;
      }
  }

  sub delete_all_comments
  {
      foreach($_[0]->section)
      {
          delete_all_comments($_);
      }
      delete_comments($_[0]);
  }

  delete_all_comments($conf);

  #
  # Transform configuration file into XML format
  #

  my $c = new Apache::Admin::Config "/path/to/file", -indent => 2
    or die $Apache::Admin::Config::ERROR;

  $c->set_write_directive(sub {
      my($self, $name, $value) = @_;
      return($self->indent.qq(<directive name="$name" value="$value />\n));
  });
  $c->set_write_section(sub {
      my($self, $name, $value) = @_;
      return($self->indent.qq(<section name="$name" value="$value">\n));
  });
  $c->set_write_section_closing(sub {
      my($self, $name) = @_;
      return($self->indent."</section>\n");
  });
  $c->set_write_comment(sub {
      my($self, $value) = @_;
      $value =~ s/\n//g;
      return($self->indent."<!-- $value -->");
  });
  print $c->dump_reformat();

package Apache::Admin::Config;

use 5.005;
use strict;
use FileHandle;

$Apache::Admin::Config::VERSION = '0.94';
$Apache::Admin::Config::DEBUG   = 0;

# We wrap the whole module part because we manipulate a tree with
# circular references. Because of the way perl's garbage collector
# works, we have to isolate circular reference in another package to
# be able to destroy circular reference before the garbage collector
# try to destroy the tree.  Without this mechanism, the DESTROY event
# will never be called.

sub new
{
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = {};
    bless $self, $class;

    my $htaccess = shift;

    my $tree = $self->{tree} = new Apache::Admin::Config::Tree(@_)
      or return;

    if(defined $htaccess)
    {
        $tree->_load($htaccess) || return undef;
    }
    else # if htaccess doesn't exists, init new one
    {
        $tree->_init || return undef;
    }
 
    return $self;
}

sub save
{
    my $reformat =
      Apache::Admin::Config::Tree::_get_arg(\@_, '-reformat!');

    my($self, $saveas) = @_;

    my $htaccess =
      defined $saveas ? $saveas : $self->{tree}->{htaccess};

    return $self->_set_error("you have to specify a location for writing configuration")
        unless defined $htaccess;

    my $fh;

    if(ref $htaccess eq 'GLOB')
    {
        $fh = $htaccess;
    }
    else
    {
        $fh = new FileHandle(">$htaccess")
            or return $self->_set_error("can't open `$htaccess' file for read");
    }

    print $fh $reformat ? $self->dump_reformat : $self->dump_raw;

    return 1;
}



sub AUTOLOAD
{
    # redirect all method to the right package
    my $self  = shift;
    my($func) = $Apache::Admin::Config::AUTOLOAD =~ /[^:]+$/g;
    return $self->{tree}->$func(@_);
}

sub DESTROY
{
    shift->{tree}->destroy;
}

package Apache::Admin::Config::Tree;

use strict;
use Carp;
use FileHandle;
use overload nomethod => \&to_string;


sub new
{
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self  = {};
    bless($self, $class);

    $self->{indent} = _get_arg(\@_, '-indent');
    $self->{create} = _get_arg(\@_, '-create!');

    $self->{'comment-grouping'} =
      ! _get_arg(\@_, '-no-comment-grouping!');
    $self->{'blank-grouping'} =
      ! _get_arg(\@_, '-no-blank-grouping!');

    # init the tree
    $self->{type}    = 'section';
    $self->{parent}  = undef;
    $self->{children}  = [];

    return($self);
}

sub dump_raw
{
    my($self) = @_;
    return join '', $self->{raw}||'', $self->_deploy(), $self->{raw2}||'';
}

sub dump_reformat
{
    my($self) = @_;
    my $string = '';
    foreach($self->select())
    {
        if($_->type eq 'section')
        {
            $string .= $self->write_section($_->name, $_->value);
            $string .= $_->dump_reformat();
            $string .= $self->write_section_closing($_->name);
        }
        else
        {
            # is it perl 5.0004 compatible ??
            my $method = "write_".$_->type;
            my $name;
            if($_->type eq 'directive')
            {
                $name = $_->name;
            }
            elsif($_->type eq 'comment')
            {
                $name = $_->value;
            }
            elsif($_->type eq 'blank')
            {
                $name = $_->{length};
            }

            my $value = defined $_->value ? $_->value : '';
            $string .= $self->$method($name||'', $value);
        }
    }

    return $string;
}

sub select
{
    my $self = shift;

    my $which = _get_arg(\@_, '-which');

    my %args;
    $args{type}  = _get_arg(\@_, '-type')  || undef;
    $args{name}  = _get_arg(\@_, '-name')  || undef;
    $args{value} = _get_arg(\@_, '-value') || undef;

    # accepting old style arguments for backward compatibilitie
    $args{type}  = shift unless defined $args{type};
    $args{name}  = shift unless defined $args{name};
    $args{value} = shift unless defined $args{value};

    # _get_arg return undef on error or empty string on not founded rule
    return $self->_set_error('malformed arguments')
        if not defined $which; 
    # $which isn't an integer
    return $self->_set_error('error in -which argument: not an integer')
        if $which =~ /[^\d\-]/;
    return $self->_set_error('too many arguments')
        if @_;
    return $self->_set_error('method not allowed')
        unless $self->{type} eq 'section';

    $args{name}  = lc($args{name})  if defined $args{name};
    $args{value} = lc($args{value}) if defined $args{value};

    my @children = @{$self->{children}};

    my $n = 0;
    my @items;
    # pre-select fields to test on each objects
    my @field_to_test = 
        grep(defined $args{$_}, qw(type name value));

    foreach my $item (@children)
    {
        my $match = 1;
        # for all given arguments, we test if it matched
        # for missing aguments, match is always true
        foreach(@field_to_test)
        {
            if(defined $item->{$_})
            {
                $match = $args{$_} eq lc($item->{$_});
            }
            else
            {
                $match = 0;
            }
            last unless $match;
        }

        if($match)
        {
            push(@items, $item);
        }
    }

    if(length $which)
    {
        return defined overload::StrVal($items[$which]) ? $items[$which] : '';
    }
    else
    {
        # We don't return just @items but transfort it in a list
        # because in scalar context, returning an array is same as
        # returning the number of ellements in it, but we want return
        # the _last_ element like a list do une scalar context. If you
        # have a better/nicer idea...
        return(@items ? @items[0 .. $#items] : ());
    }
}

sub directive
{
    my $self = shift;
    $self->select('directive', @_);
}

sub section
{
    my $self = shift;
    $self->select('section', @_);
}

sub comment
{
    my $self = shift;
    $self->select('comment', undef, @_);
}

sub blank
{
    my $self = shift;
    $self->select('blank', @_);
}

sub indent
{
    my($self) = @_;
    my $parent = $self->parent;
    my $level = 0;
    my $indent = $self->top->{indent} || 0;
    while(defined $parent)
    {
        $parent = $parent->parent;
        $level++;
    }

    return($level
        ? (($indent > 0 ? ' ' : "\t") x (abs $indent)) x $level
        : '');
}

sub write_directive
{
    my($self) = @_;
    my $code = $self->_get_var('_write_directive') || \&default_write_directive;
    &$code(@_);
}

sub set_write_directive
{
    my($self, $code) = @_;
    $self->{_write_directive} = $code;
}

sub default_write_directive
{
    my($self, $name, $value) = @_;
    return undef unless defined $name;
    $value = defined $value ? $value : '';
    return($self->indent."$name $value\n");
}

sub write_section
{
    my($self) = @_;
    my $code = $self->_get_var('_write_section') || \&default_write_section;
    &$code(@_);
}

sub set_write_section
{
    my($self, $code) = @_;
    $self->{_write_section} = $code;
}

sub default_write_section
{
    my($self, $name, $value) = @_;
    return($self->indent."<$name $value>\n");
}

sub write_section_closing
{
    my($self) = @_;
    my $code = $self->_get_var('_write_section_closing') || \&default_write_section_closing;
    &$code(@_);
}

sub set_write_section_closing
{
    my($self, $code) = @_;
    $self->{_write_section_closing} = $code;
}

sub default_write_section_closing
{
    my($self, $name) = @_;
    return($self->indent."</$name>\n");
}

sub write_comment
{
    my($self) = @_;
    my $code = $self->_get_var('_write_comment') || \&default_write_comment;
    &$code(@_);
}

sub set_write_comment
{
    my($self, $code) = @_;
    $self->{_write_comment} = $code;
}

sub default_write_comment
{
    my($self, $value) = @_;
    $value =~ s/\n/\n# /g;
    return $self->indent."# $value\n";
}

sub write_blank
{
    my($self) = @_;
    my $code = $self->_get_var('_write_blank') || \&default_write_blank;
    &$code(@_);
}

sub set_write_blank
{
    my($self, $code) = @_;
    $self->{_write_blank} = $code;
}

sub default_write_blank
{
    my($self, $number) = @_;
    return "\n" x $number;
}

sub add
{
    my $self = shift;

    my($target, $where) = _get_arg(\@_, '-before|-after|-ontop!|-onbottom!');

    $target = $target->{tree} if ref $target eq 'Apache::Admin::Config';

    # _get_arg return undef on error or empty string on not founded rule
    return($self->_set_error('malformed arguments'))
        if(not defined $target);
    return($self->_set_error('too many arguments'))
        if(@_ > 3);
    my($type, $name, $value) = @_;

    return($self->_set_error('wrong type for destination'))
        unless($self->{type} eq 'section');

    $where = defined $where ? $where : '-onbottom'; # default behavior
    if(($where eq '-before' || $where eq '-after') && defined $target)
    {
        return $self->_set_error("target `$target' isn\'t an object")
            unless ref $target && $target->isa('Apache::Admin::Config::Tree');
        return $self->_set_error('invalid target context')
            unless $target->isin($self);
    }

    my $index;

    if($where eq '-before')
    {
        $index = $target->_get_index;
    }
    elsif($where eq '-after')
    {
        $index = $target->_get_index + 1;
    }
    elsif($where eq '-ontop')
    {
        $index = 0;
    }
    elsif($where eq '-onbottom' || $where eq '')
    {
        $index = -1;
    }
    else
    {
        return $self->_set_error('malformed arguments');
    }

    my $item;

    if(ref $type)
    {
        $item = $type;
        $self->_add_child($item, $index);
    }
    elsif($type eq 'section')
    {
        return $self->_set_error('to few arguments')
            unless(defined $name and defined $value);
        my $raw = $self->write_section($name, $value);
        my $length = () = $raw =~ /\n/g;
        $item = $self->_insert_section($name, $value, $raw, $length, $index);
        $item->{raw2} = $self->write_section_closing($name);
        $item->{length2} = () = $item->{raw2} =~ /\n/g;
    }
    elsif($type eq 'directive')
    {
        return $self->_set_error('to few arguments')
            unless(defined $name);
        my $raw = $self->write_directive($name, $value);
        my $length = () = $raw =~ /\n/g;
        $item = $self->_insert_directive($name, $value, $raw, $length, $index);
    }
    elsif($type eq 'comment')
    {
        # $name contents value here
        return $self->_set_error('to few arguments')
            unless(defined $name);
        my $group = defined $value && $value ? 1 : 0;
        $item = $self->_insert_comment($name,
                    $self->write_comment($name), $index, $group);
    }
    elsif($type eq 'blank')
    {
        # enabled by default
        my $group = defined $name ? ($name ? 1 : 0) : 1;
        $item = $self->_insert_blank($self->write_blank(1), $index, $group);
    }
    else
    {
        return $self->_set_error("invalid type `$type'");
    }

    return $item;
}

sub add_section
{
    my $self = shift;
    return $self->add('section', @_);
}

sub add_directive
{
    my $self = shift;
    return $self->add('directive', @_);
}

sub add_comment
{
    my $self = shift;
    return $self->add('comment', @_);
}

sub add_blank
{
    my $self = shift;
    return $self->add('blank', @_);
}

*set_value = \&value;

sub value
{
    my $self     = shift;
    my $newvalue = shift || return $self->{value};

    my $type     = $self->{type};
    
    if($type eq 'directive' or $type eq 'section')
    {
        # keep indentation
        (my $indent = $self->{raw}) =~ s/^(\s*).*$/$1/s;
        if($newvalue =~ /\n/)
        {
            # new value is multilines
            # write the raw version
            $self->{raw} = sprintf
            (
                $indent . ($type eq 'directive' ? '%s %s' : '<%s %s>')."\n",
                $self->{name},
                join(" \\\n", split(/\n/, $newvalue)),
            );
            # clean it
            $self->{value} = join(' ', map {s/^\s*|\s*$//g; $_} split(/\n/, $newvalue));
            # count lines
            $self->{length} = 1 + $newvalue =~ s/\n//g;
        }
        else
        {
            if($type eq 'directive')
            {
                $self->{raw} = "$indent$self->{name} $newvalue\n";
            }
            else
            {
                $self->{raw} = "$indent<$self->{name} $newvalue>\n";
            }
            $self->{value} = $newvalue;
            $self->{length} = 1;
        }
    }
    elsif($type eq 'comment')
    {
        $newvalue = join(' ', split(/\n/, $newvalue));
        # keep spaces before and after the sharp comment and the
        # number of sharps used (it's pure cosmetic) and put it on
        # front of the new comment
        $self->{raw} =~ s/^(\s*\#+\s*).*$/$1$newvalue\n/s;
        $self->{value} = $newvalue
    }
    else
    {
        return($self->_set_error('method not allowed'));
    }

    return($newvalue);
}

sub move
{
    my $self = shift;
    my $dest = shift;
    return $self->_set_error("cannot move this section in a subsection of itself")
      if($dest->isin($self, '-recursif'));
    $self->unlink();
    $dest->add($self, @_);
    return;
}

sub copy
{
    my $self = shift;
    my $dest = shift;
    # clone item
    my $clone = $self->clone();
    # insert into destination
    return $dest->add($clone, @_);
}

sub clone
{
    my($self) = @_;

    my $clone = bless({});
    foreach(keys %$self)
    {
        next if $_ eq 'parent';
        $clone->{$_} = $self->{$_};
    }

    if($self->type() eq 'section')
    {
        # initialize children list
        $clone->{children} = [];
        # clone each children
        foreach($self->select())
        {
            $clone->_add_child($_->clone());
        }
    }

    return $clone;
}

sub first_line
{
    my($self) = @_;
    return 1 unless $self->parent;
    return ($self->top->_count_lines($self))[0];
}

sub last_line
{
    my($self) = @_;
    return ($self->top->_count_lines($self))[0]
      unless $self->parent;
    return ($self->top->_count_lines_last($self))[0];
}

sub count_lines
{
    my($self) = @_;
    if($self->type eq 'section')
    {
        return $self->last_line - $self->first_line + 1;
    }
    else
    {
        return $self->{length};
    }
}

sub isin
{
    my $self     = shift;
    my $recursif = _get_arg(\@_, '-recursif!');
    my $target   = shift || return $self->_set_error('too few arguments');
    $target = $target->{tree} if ref $target eq 'Apache::Admin::Config';
    return 0 unless(defined $self->{parent});
    return($self->_set_error('target is not an object of myself'))
        unless(ref $target && $target->isa('Apache::Admin::Config::Tree'));
    return($self->_set_error('wrong type for target'))
        unless($target->{type} eq 'section');
    return 1 if overload::StrVal($self) eq overload::StrVal($target);

    if($recursif)
    {
        my $parent = $self->{parent};
        while(overload::StrVal($parent) ne overload::StrVal($target))
        {
            $parent = $parent->{parent} || return 0;
        }
        return 1;
    }
    else
    {
        return(overload::StrVal($self->{parent}) eq overload::StrVal($target))
    }
}

sub to_string
{
    my($self, $other, $inv, $meth) = @_;

    if($meth eq 'eq')
    {
        if($^W and (!defined $other or !defined $self->{value}))
        {
            carp "Use of uninitialized value in string eq";
        }
        local $^W;
        return($other ne $self->{value});
    }
    elsif($meth eq 'ne')
    {
        if($^W and (!defined $other or !defined $self->{value}))
        {
            carp "Use of uninitialized value in string ne";
        }
        local $^W;
        return($other ne $self->{value});
    }
    elsif($meth eq '==')
    {
        if($^W and (!defined $other or !defined $self->{value}))
        {
            carp "Use of uninitialized value in numeric eq (==)";
        }
        local $^W;
        return($other != $self->{value});
    }
    elsif($meth eq '!=')
    {
        if($^W and (!defined $other or !defined $self->{value}))
        {
            carp "Use of uninitialized value in numeric ne (!=)";
        }
        local $^W;
        return($other != $self->{value});
    }
    elsif(!defined $self->{value})
    {
        return overload::StrVal($self);
    }
    else
    {
        return $self->{value};
    }
}

sub name
{
    return $_[0]->{name};
}
sub parent
{
    return $_[0]->{parent};
}
sub top
{
    my $top = shift;
    while(defined $top->parent())
    {
        $top = $top->parent();
    }
    return $top;
}
sub type
{
    return $_[0]->{type};
}

*remove = \&unlink;

sub unlink
{
    my($self) = @_;

    if(defined $self->{parent})
    {
        my $index = $self->_get_index;
        if(defined $index)
        {
            splice(@{$self->{parent}->{children}}, $index, 1);
        }
    }

    return 1;
}

sub destroy
{
    my($self) = @_;
    delete $self->{parent};
    foreach(@{$self->{children}})
    {
        $_->destroy;
    }
    return 1;
}

sub delete
{
    my($self) = @_;
    return $self->unlink() && $self->destroy();
}

sub error
{
    return $_[0]->top()->{__last_error__};
}

#
# Private methods
#

sub _get_var
{
    my($self, $name) = @_;

    my $value = $self->{$name};
    until(defined $value)
    {
        $self = $self->parent() or last;
    }

    return $value;
}

sub _get_index
{
    my($self) = @_;
    return unless defined $self->{parent}; # if called by top node
    my @pchildren = @{$self->{parent}->{children}};
    for(my $i = 0; $i < @pchildren; $i++)
    {
        return $i if overload::StrVal($pchildren[$i]) eq overload::StrVal($self);
    }
}

sub _deploy
{
    join '',
    map
    {
        if($_->{type} eq 'section')
        {
            ($_->{raw}, _deploy($_), $_->{raw2});
        }
        else
        {
            $_->{raw};
        }
    } @{$_[0]->{children}};
}

sub _count_lines
{
    my $c = $_[0]->{'length'} || 0;
    foreach my $i (@{$_[0]->{children}})
    {
        return($c+1, 1) if(overload::StrVal($_[1]) eq overload::StrVal($i));
        my($rv, $found) = $i->_count_lines($_[1]);
        $c += $rv;
        return($c, 1) if defined $found;
    }
    return $c + (defined $_[0]->{length2} ? $_[0]->{length2} : 0);
}

sub _count_lines_last
{
    my $c = $_[0]->{'length'};
    foreach my $i (@{$_[0]->{children}})
    {
        $c += ($i->_count_lines($_[1]))[0];
        return $c if($_[1] eq $i);
    }
    return $c + $_[0]->{length2};
}

sub _add_child
{
    my($self, $item, $index) = @_;

    $item->{parent} = $self;
    if(defined $index && $index != -1)
    {
        splice(@{$self->{children}}, $index, 0, $item);
    }
    else
    {
        push(@{$self->{children}}, $item);
    }
}

sub _insert_directive
{
    my($tree, $directive_name, $value, $line, $length, $index) = @_;

    $value = defined $value ? $value : '';
    $value =~ s/^\s+|\s+$//g;

    my $directive = bless({});
    $directive->{type} = 'directive';
    $directive->{name} = $directive_name;
    $directive->{value} = $value;
    $directive->{raw} = $line;
    $directive->{'length'} = $length;

    $tree->_add_child($directive, $index);

    return $directive;
}

sub _insert_section
{
    my($tree, $section_name, $value, $line, $length, $index) = @_;

    $value = defined $value ? $value : '';
    $value =~ s/^\s+|\s+$//g;

    my $section = bless({});
    $section->{type} = 'section';
    $section->{name} = $section_name;
    $section->{value} = $value;
    $section->{children} = [];
    $section->{raw} = $line;
    $section->{'length'} = $length;

    $tree->_add_child($section, $index);

    return $section;
}

sub _insert_comment
{
    my($tree, $value, $line, $index, $group) = @_;

    my $comment = bless({});

    # if last item is a comment, group next comment with it to make
    # multi-line comment instead of several single-line comment items
    my $_index = defined $index ? $index : -1;
    if(defined $group && $group
       && defined $tree->{children}->[$_index]
       && $tree->{children}->[$_index]->type eq 'comment')
    {
        $comment = $tree->{children}->[$_index];
        $value = "\n$value";
    }
    else
    {
        $comment->{type} = 'comment';
        $tree->_add_child($comment, $index);
    }

    $comment->{value} .= $value;
    $comment->{raw} .= $line;
    $comment->{'length'}++;

    return $comment;
}

sub _insert_blank
{
    my($tree, $line, $index, $group) = @_;

    my $blank = bless({});

    # if last item is a blank line, group next blank line with it to
    # make multi-line blank item instead of several single-line blank
    # items
    my $_index = defined $index ? $index : -1;
    if(defined $group && $group
       && defined $tree->{children}->[$_index]
       && $tree->{children}->[$_index]->type eq 'blank')
    {
        $blank = $tree->{children}->[$_index];
    }
    else
    {
        $blank->{type} = 'blank';
        $tree->_add_child($blank, $index);
    }

    $blank->{raw} .= $line;
    $blank->{'length'}++;

    return $blank;
}

sub _parse
{
    my($self, $fh) = @_;
    my $file = $self->{htaccess} || '[inline]';

    my $cgroup = $self->{'comment-grouping'};
    my $bgroup = $self->{'blank-grouping'};
    # level is used to stock reference to the curent level, level[0] is the root level
    my @level = ($self);
    my($line, $raw_line);
    my $n = 0;
    while((defined $fh) && ($line = scalar <$fh>) && (defined $line))
    {
        $n++;
        my $length = 1;
        $raw_line = $line;

        while($line !~ /^\s*#/ && $line =~ s/\\$//)
        {
            # line is truncated, we want the entire line
            $n++;
            $length++;
            chomp($line);
            my $next .= <$fh> 
                or return $self->_set_error(sprintf('%s: syntax error at line %d', $file, $n));
            $raw_line .= $next;
            $next =~ s/^\s*|\s*$//g;
            $line .= $next;
        }

        $line =~ s/^\s*|\s*$//g;

        if($line =~ /^\s*#\s?(.*?)\s*$/)
        {
            # it's a comment
            _insert_comment($level[-1], $1, $raw_line, undef, $cgroup);
        }
        elsif($line eq '')
        {
            # it's a blank line
            _insert_blank($level[-1], $raw_line, undef, $bgroup);
        }
        elsif($line =~ /^(\w+)(?:\s+(.*?)|)$/)
        {
            # it's a directive
            _insert_directive($level[-1], $1, $2, $raw_line, $length);
        }
        elsif($line =~ /^<\s*(\w+)(?:\s+([^>]+)|\s*)>$/)
        {
            # it's a section opening
            my $section = _insert_section($level[-1], $1, $2, $raw_line, $length);
            push(@level, $section);
        }
        elsif($line =~ /^<\/\s*(\w+)\s*>$/)
        {
            # it's a section closing
            my $section_name = lc $1;
            return $self->_set_error(sprintf('%s: syntax error at line %d', $file, $n)) 
              if(!@level || $section_name ne lc($level[-1]->{name}));
            $level[-1]->{raw2} = $raw_line;
            $level[-1]->{length2} = $length;
            pop(@level);
        }
        else
        {
            return $self->_set_error(sprintf('%s: syntax error at line %d', $file, $n));
        }
    }

    eval('use Data::Dumper; print Data::Dumper::Dumper($self), "\n";') if($Apache::Admin::Config::DEBUG);

    return 1;
}

sub _get_arg
{
    my($args, $motif) = @_;
    # motif is a list of searched argument separated by a pipe
    # each arguments can be ended by a ! for specifing that it don't wait for a value
    # (ex: "-arg1|-arg2!" here -arg2 is boolean)
    # return (value, argname)

    return '' unless(@$args);
    for(my $n = 0; $n < @$args; $n++)
    {
        foreach my $name (split(/\|/, $motif))
        {
            my $boolean = ($name =~ s/\!$//);
            if(defined $args->[$n] && !ref($args->[$n]) && $args->[$n] eq $name)
            {
                return(undef) if(!$boolean && $n+1 >= @$args); # malformed argument
                my $value = splice(@$args, $n, ($boolean?1:2));
                $value = '' unless defined $value;
                return(wantarray ? ($value, $name) : $value); # suppres argument name and its value from the arglist and return the value
            }
        }
    }
    return '';
}

sub _init
{
    my $self = shift;
    return $self->_parse;
}

sub _load
{
    my($self, $htaccess) = @_;
    my @htaccess;
    my $fh;

    $self->{htaccess} = $htaccess;

    if(ref $htaccess eq 'GLOB')
    {
        $fh = $htaccess;
    }
    else
    {
        # just return true if file doesn't exist and -create was enabled
        return 1 if(not -f $htaccess and $self->{create});
        
        return $self->_set_error("`$htaccess' not readable") unless(-r $htaccess);
        $fh = new FileHandle($htaccess) or return $self->_set_error("can't open `$htaccess' file for reading");
    }
    
    return $self->_parse($fh);
}

sub _set_error
{
    my $self = shift;
    $Apache::Admin::Config::ERROR = $self->top->{__last_error__} = join('', (caller())[0].': ', @_);
    return;
}

1;