File Coverage

blib/lib/Apache/Description.pm

Criterion	Covered	Total	%
statement	19	75	25.3
branch	1	44	2.2
condition	0	9	0.0
subroutine	6	16	37.5
pod	9	11	81.8
total	35	155	22.5

package Apache::Description;

use 5.008;
use strict;
use warnings;
use IO::File;
use Carp;

our $VERSION = '0.5';

my ($filename, $fh, @prev);
my $regexp = <<'END_RE';
^AddDescription
             \s+
                  ("?)                # quote ?
                    (([^"\\]|\\")+)   # description
                    \s*
                   \1                  # quote ?
             \s+

                   ("?)               # quote ?
                     (([^"\\]|\\")+)        # filename
                     \s*
                    \4                 # quote ?
$ # end of regexp
END_RE

sub new {
  my $self = shift;

  ## you can give a filename in argument
  $filename = shift;
  $self->parse  if  defined $filename;

  return bless {}, $self;
}

## this subroutine checks the filename
sub parse {
  my $self = shift;

  ## have we already open a file ?
  if ( defined $fh ) {
    carp "$filename is already in use\n";

  } else {
    $filename = $filename ? $filename : shift;

    if ( (not defined $filename) or (not -e $filename) ) {
      croak "invalid filename : $filename";
    }

    $self->open();
  }
}

## just open the file .htaccess
sub open {
  $fh = IO::File->new($filename, "r+");

  if ( not defined $fh) {
    croak "impossible to open $filename in read-write : $!";
  }
}

## add a description
sub add($$){
  my ($self, $file, $desc) = @_;

  print $fh qq/AddDescription "$desc" "$file"\n/;
}


## remove an entry
## this operation is "expensive" : two files are created, and I
## need to parse the whole file.
## if there are more than one directive for the file wanted, they are
## both deleted.
sub remove($) {
  my ($self, $wanted) = @_;
  my $fd;

  $fh->setpos(0);
  $fd = IO::File->new(">/tmp/htaccess.$$");

  croak "no file descriptor available : $!" unless (defined $fh or not defined $fd);

  while ( <$fh> ) {
    chomp if defined;

    if ( m/$regexp/xio ) {

      if ($5 ne $wanted)
        { print $fd "$_\n" }

    } else {
      print $fd "$_\n";
    }
  }

  croak "no file descriptor available : $!" if (not defined $fh or not defined $fd);

  rename "/tmp/htaccess.$$", $filename
    or croak "rename(htaccess.$$,$filename) : $!";
}

## this function can return an array, or a scalar
## according to the context of the next description.
##
## @ array = ($filename, $description)
##
## $ scal  = qq/$filename:$description/
##
sub next {
  my @data;

  croak "no file descriptor available" unless defined $fh;

  while ( <$fh> ) {
    chomp if defined;

    next unless m/$regexp/xio;
    @data = ($5, $2);

    ## storing the last directive
    @prev = @data;
    last;
  }

   return wantarray ? @data : join ':',@data;
}

## return the previous directive.
## it's the same format than next()
sub prev {
  return wantarray ? @prev : join ':',@prev;
}

## returns all descriptions in a hash reference
##
sub getall {
  my $self = shift;
  my (%hash, $desc);

  croak "no file descriptor available" unless defined $fh;

  while ( my ($f, $d) = $self->next() ) {
    last if not defined $f;

    $hash{"$f"} = $d;
  }

  return \%hash;
}

sub get($) {
  my $self   = shift;
  my $wanted = shift;
  my $ret    = undef;

  croak "no file descriptor available" unless defined $fh;

  while ( my ($f, $d) = $self->next() ) {
    last if not defined $f;

    if ( $f eq $wanted) {
      $ret = $d;
      last;
    }
  }

  return $ret;
}

sub rename {
  print qq/Not implemented yet\n/;
}

sub ispresent($) {
  my $self = shift;
  my $file = shift;

  return $self->get($file) ? 1 : 0;
}


1;

__END__