File Coverage

blib/lib/Tie/TextDir.pm

Criterion	Covered	Total	%
statement	107	128	83.5
branch	37	68	54.4
condition	8	12	66.6
subroutine	21	22	95.4
pod			n/a
total	173	230	75.2

package Tie::TextDir;

use strict;
use warnings;

use File::Spec;
use File::Temp;
use File::Path;
use File::Find::Iterator;
use File::Basename;

use Symbol;
use Fcntl qw(:DEFAULT);
use Carp;

our $VERSION = '0.07';

sub TIEHASH {
  croak "usage: tie(%hash, 'Tie::TextDir', \$path, [mode], [perms], [levels])"
    unless 2 <= @_ and @_ <= 5;

  my ($package, $path, $mode, $perms, $levels) = @_;
  $mode ||= 'ro';
  $perms ||= 0775;
  $levels ||= 0;
  $levels = 0 if $levels < 0;
  my $self = bless {}, $package;

  # Save levels
  $self->{LEVELS} = $levels;

  # Can we make changes to the database?
  if ($mode eq 'rw') {
    $self->{MODE} = O_CREAT | O_RDWR;
  } elsif ($mode eq 'ro') {
    $self->{MODE} = O_RDONLY;
  } else {
    # Assume $mode is a bitmask of Fcntl flags
    $self->{MODE} = $mode;
  }

  # Nice-ify $path:
  $path =~ s#/$##;
  croak "$path is not a directory" if -e $path and not -d _;
  unless (-e $path) {
    croak "$path does not exist" unless $self->{MODE} & O_CREAT;
    mkdir $path, $perms or croak "Can't create $path: $!";
  }
  $self->{PATH} = $path;

  # Get an iterator over the directory
  $self->{FIND} = File::Find::Iterator->create(dir => [$self->{PATH}],
					       filter => sub { -f });

  return $self;
}

sub FETCH {
  my ($self, $key) = @_;
  if ( !$self->_key_okay($key) ) {
    carp "Bad key '$key'" if $^W;
    return;
  }

  my $file = File::Spec->catfile($self->{PATH}, $self->_key_to_path($key));
  return unless -e $file;

  local *FH;
  unless (open( FH, "< $file" )) {
    carp "Can't open $file for reading: $!";
    return;
  }
  my $value;
  sysread FH, $value, ( stat FH )[7];
  close FH;
  return $value;
}


sub STORE {
  my ($self, $key) = (shift, shift);
  my $file = File::Spec->catfile($self->{PATH}, $self->_key_to_path($key));
  croak "No write access for '$file'" unless $self->{MODE} & O_RDWR;

  if ( !$self->_key_okay($key) ) {
    carp "Bad key '$key'" if $^W;
    return;
  }

  # Use temp file for writing, and then rename to make the update atomic
  my ($fh, $tmpname) = File::Temp::tempfile(DIR => $self->{PATH}, CLEANUP => 1);
  print $fh $_[0];
  close $fh;
  rename ($tmpname, $file) or croak ("can't rename temp file $tmpname to $file: $!");
}


sub DELETE {
  my ($self, $key) = @_;
  my $file = File::Spec->catfile($self->{PATH}, $self->_key_to_path($key));
  croak "No write access for '$file'" unless $self->{MODE} & O_RDWR;

  if ( !$self->_key_okay($key) ) {
    carp "Bad key '$key'" if $^W;
    return;
  }

  return unless -e $file;

  my $return;
  $return = $self->FETCH($key) if defined wantarray;  # Don't bother in void context

  unlink $file or croak "Couldn't delete $file: $!";

  if ($self->{LEVELS}) {
    my $path = $file;
    for (1..$self->{LEVELS}) {
      $path = dirname($path);
      rmdir $path;
    }
  }

  return $return;
}

sub CLEAR {
  my $self = shift;
  croak "No write access for '$self->{PATH}'" unless $self->{MODE} & O_RDWR;

  $self->{FIND}->first;

  my $entry;
  while (defined ($entry = $self->{FIND}->next)) {
    unlink $entry or croak "can't remove $entry: $!";

    if ($self->{LEVELS}) {
      my $path = $entry;
      for (1..$self->{LEVELS}) {
	$path = dirname($path);
	rmdir $path;
      }
    }
  }
}

sub EXISTS {
  my ($self, $key) = @_;
  if ( !$self->_key_okay($key) ) {
    carp "Bad key '$key'" if $^W;
    return;
  }
  return -e File::Spec->catfile($self->{PATH}, $self->_key_to_path($key));
}


sub FIRSTKEY {
  my $self = shift;

  $self->{FIND}->first;
  my $entry = $self->{FIND}->next;
  $entry = _path_to_key($entry) if $entry;
  return $entry;
}


sub NEXTKEY {
  my $entry = shift()->{FIND}->next;
  $entry = _path_to_key($entry) if $entry;
  return $entry;
}

sub _key_okay {
  return 0 if $_[1] =~ /^\.{0,2}$/;
  return 1;
}

sub _path_to_key {
  return fileparse($_[0]);
}

sub _key_to_path {
  my ($self, $key) = @_;
  my $levels = $self->{LEVELS};

  # try to bail out as soon as we can if no levels is needed
  return $key unless $levels;

  # Create the tree structure
  my @key = split //, $key;
  $levels = scalar(@key) if scalar(@key) < $levels;
  my $prefix = File::Spec->catfile(map { join("", @key[0..$_]) } (0..$levels-1));

  # make sure the path exists, so we can create the file.
  my $dir = File::Spec->catfile($self->{PATH}, $prefix);
  mkpath($dir) unless -d $dir;

  return File::Spec->catfile($prefix, $key);
}

1;

__END__