File Coverage

blib/lib/Tie/SymlinkTree.pm

Criterion	Covered	Total	%
statement	132	248	53.2
branch	42	102	41.1
condition	17	46	36.9
subroutine	25	41	60.9
pod	0	7	0.0
total	216	444	48.6

package Tie::SymlinkTree;
use strict;
use bytes;
use Encode;
use Tie::Indexer;

our $VERSION = '1.1';

{
    package Tie::SymlinkTree::Array;
    sub id { tied(@{shift()})->id(@_) }
    sub search { tied(@{shift()})->search(@_) }
}

{
    package Tie::SymlinkTree::Hash;
    sub id { tied(%{shift()})->id(@_) }
    sub search { tied(%{shift()})->search(@_) }
}

sub encode_value {
  no bytes;
  my $val = shift;
  return undef if !defined $val;
  $val =~ s#\x{feff}#\x{feff}feff#g;
  $val =~ s#\x{0000}#\x{feff}0000#g;
  $val = "\x{feff}" if (length($val) == 0);
  $val = encode_utf8($val);
  return $val;
}

sub decode_value {
  no bytes;
  my $val = shift;
  return undef if !defined $val;
  $val = decode_utf8($val);
  $val = "" if ($val eq "\x{feff}");
  $val =~ s#\x{feff}0000#\x{0000}#g;
  $val =~ s#\x{feff}feff#\x{feff}#g;
  return $val;
}

sub encode_key {
  no bytes;
  my $key = shift;
  $key = '' if !defined $key;
  $key =~ s#\x{feff}#\x{feff}feff#g;
  $key =~ s#\x{0000}#\x{feff}0000#g;
  $key =~ s#/#\x{feff}002f#g;
  $key =~ s#^\.#\x{feff}002e#g;
  $key = "\x{feff}" if (length($key) == 0);
  $key = encode_utf8($key);
  return $key;
}

sub decode_key {
  no bytes;
  my $key = shift;
  return undef if !defined $key;
  $key = decode_utf8($key);
  $key = "" if ($key eq "\x{feff}");
  $key =~ s#\x{feff}002e#.#g;
  $key =~ s#\x{feff}002f#/#g;
  $key =~ s#\x{feff}0000#\x{0000}#g;
  $key =~ s#\x{feff}feff#\x{feff}#g;
  return $key;
}

sub TIEARRAY {
  my ($package, $path) = @_;
  my $self = (ref $package?$package:bless {}, $package);
  $self->{ARRAY} = 1;
  return $self->TIEHASH($path);
}

sub TIEHASH {
  my ($package, $path) = @_;
  die "usage: tie(%hash, 'Tie::SymlinkTree', \$path)" if @_ != 2;
  my $self = (ref $package?$package:bless {}, $package);

  $path =~ s#/*$#/#;
  die "$path is invalid" if $path =~ m#/\.\.?(/|$)#;
  die "$path is not a directory" if -e $path and -l $path;
  if (! -e $path) {
    mkdir $path or -d $path or die "Can't create $path: $!";
    symlink(".",$path.".array") if $self->{ARRAY};
  } # race condition: assigning array and hash to one location at the same time
  die "$path has wrong type" if (-e $path.".array" xor $self->{ARRAY});
  $self->{PATH} = $path;

  return $self;
}

sub FETCH {
  my ($self, $key) = @_;
  $key = encode_key($key);
  if (-d $self->{PATH}.$key) {
	if (-e $self->{PATH}.$key."/.array") {
	    my @tmp;
	    tie @tmp, ref($self), $self->{PATH}.$key;
	    return bless \@tmp, 'Tie::SymlinkTree::Array';
	} else {
	    my %tmp;
	    tie %tmp, ref($self), $self->{PATH}.$key;
	    return bless \%tmp, 'Tie::SymlinkTree::Hash';
	}
  } else {
	return decode_value(readlink($self->{PATH}.$key));
  }
}


sub STORE {
    my ($self, $key, $val, $recursion) = @_;
    $key = encode_key($key);
    die "no objects allowed" if ref($val) && ref($val) ne 'HASH' && ref($val) ne 'ARRAY';
    Tie::Indexer::deindex_node($self,$val,$key);
    if (!defined($val)) {
  	open(my $fh,'>',$self->{PATH}.".$$~".$key) || die "Error while storing: $!";
	close($fh);
	rename($self->{PATH}.".$$~".$key,$self->{PATH}.$key) or $recursion or do {$self->DELETE($_[1]);$self->STORE($_[1],$val,1);};
    } elsif (!ref($val)) {
  	symlink(encode_value($val),$self->{PATH}.".$$~".$key) || die "Error while storing: $!";
	rename($self->{PATH}.".$$~".$key,$self->{PATH}.$key) or $recursion or do {$self->DELETE($_[1]);$self->STORE($_[1],$val,1);};
    } elsif (ref($val) eq 'ARRAY' || ref($val) eq 'Tie::SymlinkTree::Array') {
  	my @tmp = @$val;
	eval { tie @$val, ref($self), $self->{PATH}.$key; };
	if (!$recursion && $@) {$self->DELETE($key);$self->STORE($_[1],$val,1);}
	@$val = @tmp;
    } else {
  	my %tmp = %$val;
	eval { tie %$val, ref($self), $self->{PATH}.$key; };
	if (!$recursion && $@) {$self->DELETE($key);$self->STORE($_[1],$val,1);}
	%$val = %tmp;
    }
    Tie::Indexer::index_node($self,$val,$key);
}


sub DELETE {
  my ($self, $key) = @_;
  $key = encode_key($key);
  my $val = $self->FETCH($key);
  Tie::Indexer::deindex_node($self,$val,$key);
  if (UNIVERSAL::isa($val,'ARRAY')) {
  	my @tmp = @$val;
	for my $i (0..$#tmp) {
	    $tmp[$i] = delete $val->[$i];
	}
	$val = \@tmp;
	unlink $self->{PATH}.$key."/.array";
  } elsif (UNIVERSAL::isa($val,'HASH')) {
  	my %tmp = %$val;
	for my $k (keys %tmp) {
	    $tmp{$k} = delete $val->{$k};
	}
	$val = \%tmp;
  } else {
        if (substr($self->id,0,1) ne '.' && -d $self->{PATH}."../.index-$key") {
	    my $path = $self->{PATH};
	    $path =~ s#[^/]*/$##;
	    tie my %index, ref($self), $path.".index-$key/";
	    delete $index{$val}{$self->id};
	}
  }
  unlink $self->{PATH}.$key;
  rmdir $self->{PATH}.$key;
  return $val;
}

sub _clear {
  my ($dir) = @_;
  die "empty directory" unless $dir;
  my $dh;
  opendir($dh,$dir);
  while (defined (my $subdir = readdir($dh))) {
  	next if ($subdir eq '.' || $subdir eq '..');
	unlink($dir.$subdir) or do {
		_clear($dir.$subdir."/");
		rmdir($dir.$subdir);
	}
  }
  closedir($dh);
}

sub CLEAR {
  my ($self) = @_;
  $self->lock;
  _clear($self->{PATH});
  $self->unlock;
}

sub EXISTS {
  my ($self, $key) = @_;
  $key = encode_key($key);
  return -e $self->{PATH}.$key || -l $self->{PATH}.$key;
}


sub DESTROY {
}


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

  my $dh;
  opendir($dh,$self->{PATH});
  $self->{HANDLE} = $dh;
  my $entry;
  while (defined ($entry = readdir($self->{HANDLE}))) {
    return decode_key($entry) unless (substr($entry,0,1) eq '.');
  }
  return;
}


sub NEXTKEY {
  my ($self) = @_;
  my $entry;
  while (defined ($entry = readdir($self->{HANDLE}))) {
    return decode_key($entry) unless (substr($entry,0,1) eq '.');
  }
  return;
}

sub FETCHSIZE {
  my ($self) = @_;
  my $dh;
  opendir($dh,$self->{PATH});
  my $max = -1;
  my $entry;
  while (defined ($entry = readdir($dh))) {
    next if substr($entry,0,1) eq '.';
    $max = int($entry) if $entry > $max;
  }
  return $max+1;
}

sub STORESIZE {
  my ($self, $size) = @_;
  $self->lock;
  $size = int($size);
  while (-e $self->{PATH}.$size) {
  	$self->DELETE($size);
	$size++;
  }
  $self->unlock;
}

sub EXTEND { }
sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
sub SHIFT { shift->SPLICE(0,1) }

sub PUSH {
  my ($self, $value) = @_;
  $self->lock;
  my $key = $self->FETCHSIZE;
  $self->STORE($key,$value);
  $self->unlock;
  return $key+1;
}

sub POP {
  my ($self, $value) = @_;
  $self->lock;
  my $key = $self->FETCHSIZE-1;
  my $val = $self->FETCH($key);
  $self->DELETE($key);
  $self->unlock;
  return $val;
}

sub SPLICE {
    my $self = shift;
    $self->lock;
    my $size  = $self->FETCHSIZE;
    my $off = (@_) ? shift : 0;
    $off += $size if ($off < 0);
    my $len = (@_) ? shift : $size - $off;
    $len += $size - $off if $len < 0;
    my @result;
    for (my $i = 0; $i < $len; $i++) {
        push(@result,$self->FETCH($off+$i));
    }
    $off = $size if $off > $size;
    $len -= $off + $len - $size if $off + $len > $size;
    if (@_ > $len) {
        # Move items up to make room
        my $d = @_ - $len;
        my $e = $off+$len;
        for (my $i=$size-1; $i >= $e; $i--) {
	    rename($self->{PATH}.$i,$self->{PATH}.($i+$d));
        }
    }
    elsif (@_ < $len) {
        # Move items down to close the gap
        my $d = $len - @_;
        my $e = $off+$len;
        for (my $i=$off+$len; $i < $size; $i++) {
	    rename($self->{PATH}.$i,$self->{PATH}.($i-$d));
        }
    }
    for (my $i=0; $i < @_; $i++) {
        $self->STORE($off+$i,$_[$i]);
    }
    $self->unlock;
    return wantarray ? @result : pop @result;
}

sub lock {
  my ($self) = @_;
  if (!$self->{locked}++) {
	  my $i = 0;
	  while (!symlink($$,$self->{PATH}.".lock") && $i++ < 40) {
		select('','','',.25);
	  }
  }
}

sub unlock {
  my ($self) = @_;
  if (!--$self->{locked}) {
	  unlink($self->{PATH}.".lock");
  }
}

sub id {
    my ($self) = @_;
    return ($self->{PATH} =~ m{/([^/]+)/$})[0];
}

sub _get_index {
	my ($tie, $create) = @_;
	return undef if (!$create && ! -d $tie->{PATH}.".index/");
	tie my %index, ref($tie), $tie->{PATH}.".index/";
	return \%index;
}

BEGIN {
	*search = \&Tie::Indexer::search;
}

no warnings;
"Dahut!";
__END__