Fuse::Simple - Simple way to write filesystems in Perl using FUSE

  use Fuse::Simple qw(accessor main);
  my $var = "this is a variable you can modify. write to me!\n";
  my $filesystem = {
    foo => "this is the contents of a file called foo\n",
    subdir => {
      "foo"  => "this foo is in a subdir called subdir\n",
      "blah" => "this blah is in a subdir called subdir\n",
    },
    "blah" => \ "subdir/blah",        # scalar refs are symlinks
    "magic" => sub { return "42\n" }, # will be called to get value
    "var"  => accessor(\$var),        # read and write this variable
    "var2" => accessor(\$var),        # and the same variable
    "var.b" => accessor(\ my $tmp),   # and an anonymous var
  };
  main(
    "mountpoint" => "/mnt",      # actually optional
    "debug"      => 0,           # for debugging Fuse::Simple. optional
    "fuse_debug" => 0,           # for debugging FUSE itself. optional
    "threaded"   => 0,           # optional
    "/"          => $filesystem, # required :-)
  );

  sub mysub {
    my ($contents, $off) = @_;
    if (defined $contents) {
      # we are writing to this file
    } else {
      # we are to return the contents
    }
  }
  my $fs = {
    "magic" => \&mysub,
  };

  cat /mnt/magic
    mysub();           # the file is being read
  echo "123" > /mnt/magic
    mysub("123\n", 0); # the file is being written
  : > /mnt/magic
    mysub("", 0);      # the file is being truncated

  ls /mnt/             # mysub("");
  ls /mnt/magic        # return cached copy
  ls -Fal /mnt/magic   # return cached copy
  cat /mnt/magic       # return cached copy, but clear cache
  cat /mnt/magic       # mysub("");          and clear cache
  ls /mnt/magic        # mysub("");
  ls /mnt/magic        # return cached copy
  echo foo >/mnt/magic # mysub("foo",0);
  ls /mnt/magic        # mysub("");
  ls /mnt/magic        # return cached copy

  see L</SYNOPSIS>

    perldoc Fuse::Simple

#!/usr/bin/perl -w
package Fuse::Simple; # in file Fuse/Simple.pm

######################################################################
# By "Nosey" Nick Waterman of Nilex
#   <perl@noseynick.org>   http://noseynick.org/
# (C) Copyright 2006 Nilex - All wrongs righted, all rights reserved.
######################################################################
# Requirements:
use 5.008;
use strict;
use warnings;
use Carp;
use Fuse;
use Errno qw(:POSIX);         # ENOENT EISDIR etc
use Fcntl qw(:DEFAULT :mode); # S_IFREG S_IFDIR, O_SYNC O_LARGEFILE etc.
use Switch;
# use diagnostics;

######################################################################
# Module stuff:
######################################################################
use Exporter;
our @ISA = qw(Exporter);
our $VERSION = '1.00';

# thou shalt not pollute, thou shalt not export more than thou needest.
our @EXPORT    = qw( );
our @EXPORT_OK = qw(
    main fetch runcode saferun fserr nocache wrap quoted
    dump_open_flags accessor easy_getattr
    fs_not_imp fs_flush fs_getattr fs_getdir fs_open fs_read fs_readlink
    fs_release fs_statfs fs_truncate fs_write
);
our %EXPORT_TAGS =
  (
      'all'     => \@EXPORT_OK,
      'DEFAULT' => \@EXPORT,
      'usual'   => [qw(main accessor fserr nocache)],
      'debug'   => [qw(wrap quoted dump_open_flags)],
      'tools'   => [qw(fetch runcode saferun easy_getattr)],
      'filesys' => [qw(
	  fs_not_imp fs_flush fs_getattr fs_getdir fs_open fs_read
	  fs_readlink fs_release fs_statfs fs_truncate fs_write
      )],
  );

######################################################################
# Some useful stuff
######################################################################

our $debug = 0; # can be set if you really really need it to be
my $ctime = time();
my $uid   = $>;
my $gid   = $) + 0;
our $fs    = {
    # "empty" dir by default
    "README" => "You forgot to pass a '/' parameter to Fuse::Simple::main!\n"
};

######################################################################

sub main {
    # some default args
    my %args = (
	"mountpoint"  => $ARGV[0] || "",
	"debug"       => $debug,
	"fuse_debug"  => 0,
	"threaded"    => 0,
	"/"           => $fs,
    );
    # the default subs
    my %fs_subs = (
	"chmod"       => \&fs_not_imp,
	"chown"       => \&fs_not_imp,
	"flush"       => \&fs_flush,
	"fsync"       => \&fs_not_imp,
	"getattr"     => \&fs_getattr,
	"getdir"      => \&fs_getdir,
	"getxattr"    => \&fs_not_imp,
	"link"        => \&fs_not_imp,
	"listxattr"   => \&fs_not_imp,
	"mkdir"       => \&fs_not_imp,
	"mknod"       => \&fs_not_imp,
	"open"        => \&fs_open,
	"read"        => \&fs_read,
	"readlink"    => \&fs_readlink,
	"release"     => \&fs_release,
	"removexattr" => \&fs_not_imp,
	"rmdir"       => \&fs_not_imp,
	"rename"      => \&fs_not_imp,
	"setxattr"    => \&fs_not_imp,
	"statfs"      => \&fs_statfs,
	"symlink"     => \&fs_not_imp,
	"truncate"    => \&fs_truncate,
	"unlink"      => \&fs_not_imp,
	"utime"       => sub{return 0},
	"write"       => \&fs_write,
    );
    my $name;
    # copy across the arg supplied to main()
    while ($name = shift) {
	$args{$name} = shift;
    }
    # except extract these ones back out.
    $debug = delete $args{"debug"};
    $args{"debug"} = delete( $args{"fuse_debug"} ) || 0;
    $fs = delete $args{"/"};
    # add the functions, if not already defined.
    # wrap in debugger if debug is set.
    for $name (keys %fs_subs) {
	my $sub = $fs_subs{$name};
	$sub = wrap($sub, $name) if $debug;
	$args{$name} ||= $sub;
    }
    Fuse::main(%args);
}

sub fetch {
    my ($path, @args) = @_;
    
    my $obj = $fs;
    for my $elem (split '/', $path) {
	next if $elem eq ""; # skip empty // and before first /
	$obj = runcode($obj); # if there's anything to run
	# the dir we're changing into must be a hash (dir)
	return fserr(ENOTDIR()) unless ref($obj) eq "HASH";
	# note that ENOENT and undef are NOT the same thing!
	return fserr(ENOENT()) unless exists $obj->{$elem};
	$obj = $obj->{$elem};
    }
    
    return runcode($obj, @args);
}

my %codecache = ();
sub runcode {
    my ($obj, @args) = @_;
    
    while (ref($obj) eq "CODE") {
	my $old = $obj;
	if (@args) { # run with these args. don't cache
	    delete $codecache{$old};
	    print "running $obj(",quoted(@args),") NO CACHE\n" if $debug;
	    $obj = saferun($obj, @args);
	} elsif (exists $codecache{$obj}) { # found in cache
	    print "got cached $obj\n" if $debug;
	    $obj = $codecache{$obj}; # could be undef, or an error, BTW
	} else {
	    print "running $obj() to cache\n" if $debug;
	    $obj = $codecache{$old} = saferun($obj);
	}
	
	if (ref($obj) eq "NOCACHE") {
	    print "returned a nocache() value - flushing\n" if $debug;
	    delete $codecache{$old};
	    $obj = $$obj;
	}
	
	print "returning ",ref($obj)," ",
	  defined($obj) ? $obj : "undef",
	  "\n" if $debug;
    }
    return $obj;
}

sub saferun {
    my ($sub, @args) = @_;
    
    my $ret = eval { &$sub(@args) };
    my $died = $@;
    if (ref($died)) {
	# we can die fserr(ENOTSUP) if we want!
	print "+++ Error $$died\n" if ref($died) eq "ERROR";
	return $died;
    } elsif ($died) {
	print "+++ $died\n";
	# stale file handle? moreorless?
	return fserr(ESTALE());
    }
    return $ret;
}

sub fserr {
    return bless(\ shift, "ERROR"); # yup, utter abuse of bless   :-)
}

sub nocache {
    return bless(\ shift, "NOCACHE"); # yup, utter abuse of bless   :-)
}

my @indent = ();
sub wrap {
    my ($sub, @name_etc) = @_;
    
    return sub {
	print "@indent> @name_etc(", quoted(@_), ")\n";
	push @indent, "  ";
	my @ret = eval { &$sub(@_) };
	my $died = $@;
	pop @indent;
	die $died if ref($died); # die(some object), EG die(fserr(E2BIG))
	die "@indent! $died" if $died;
	print "@indent< =", quoted(@ret), "\n";
	return wantarray ? @ret : $ret[0];
    };
}

my %escaped = (
    '$' => '$', '@' => '@', '"' => '"', "\\" => "\\",
    "\t" => "t", "\r" => "r", "\n" => "n",
    "\f" => "f", "\a" => "a", "\e" => "e",
);
sub quoted {
    my @ret = ();
    
    for my $n (@_) {
	# special case for undefined vars:
	if (not defined($n)) { push @ret, "undef"; next; }
	# digits (that are really digits without newlines) can be printed
	# without quoting:
	if ($n =~ /^-?\d+\.?\d*$/  &&  $n !~ /\n/) { push @ret, $n; next; }
	
	# other stuff needs quoting and escaping in fun ways:
	my $s = $n;
	$s =~ s/([\$\@\"\\\t\n\r\f\a\e])/\\$escaped{$1}/g;
	$s =~ s/([^ -~])/sprintf('\x{%x}',ord($1))/ge;
	push @ret, '"'.$s.'"';
    }
    return join(", ", @ret);
}

sub dump_open_flags {
    my $flags = shift;
    
    printf "  flags: 0%o = (", $flags;
    for my $bits (
	[ O_ACCMODE(),   O_RDONLY(),     "O_RDONLY"    ],
	[ O_ACCMODE(),   O_WRONLY(),     "O_WRONLY"    ],
	[ O_ACCMODE(),   O_RDWR(),       "O_RDWR"      ],
	[ O_APPEND(),    O_APPEND(),    "|O_APPEND"    ],
	[ O_NONBLOCK(),  O_NONBLOCK(),  "|O_NONBLOCK"  ],
	[ O_SYNC(),      O_SYNC(),      "|O_SYNC"      ],
	[ O_DIRECT(),    O_DIRECT(),    "|O_DIRECT"    ],
	[ O_LARGEFILE(), O_LARGEFILE(), "|O_LARGEFILE" ],
	[ O_NOFOLLOW(),  O_NOFOLLOW(),  "|O_NOFOLLOW"  ],
    ) {
	my ($mask, $flag, $name) = @$bits;
	if (($flags & $mask) == $flag) {
	    $flags -= $flag;
	    print $name;
	}
    }
    printf "| 0%o !!!", $flags if $flags;
    print ")\n";
}

sub accessor {
    my $var_ref = shift;
    
    croak "accessor() requires a reference to a scalar var\n"
      unless defined($var_ref) && ref($var_ref) eq "SCALAR";
    
    return sub {
	my $new = shift;
	$$var_ref = $new if defined($new);
	return $$var_ref;
    }
}

sub easy_getattr {
    my ($mode, $size) = @_;
    
    return (
	0, 0,       # $dev, $ino,
	$mode,
	1,          # $nlink, see fuse.sourceforge.net/wiki/index.php/FAQ
	$uid, $gid, # $uid, $gid,
	0,          # $rdev,
	$size,      # $size,
	$ctime, $ctime, $ctime, # actually $atime, $mtime, $ctime,
	1024, 1,    # $blksize, $blocks,
    );
}

sub fs_not_imp { return -ENOSYS() }

sub fs_flush {
    # we're passed a path, but finding my coderef stuff from a path
    # is a bit of a 'mare. flush the lot, won't hurt TOO much.
    print "Flushing\n" if $debug;
    %codecache = ();
    return 0;
}

sub fs_getattr {
    my $path = shift;
    my $obj = fetch($path);
    
    # undef doesn't actually mean "file not found", it could be a coderef
    # file-sub which has returned undef.
    return easy_getattr(S_IFREG | 0200, 0) unless defined($obj);
    
    switch (ref($obj)) {
	case "ERROR" {  # this is an error to be returned.
	    return -$$obj;
	}
	case "" {       # this isn't a ref, it's a real string "file"
	    return easy_getattr(S_IFREG | 0644, length($obj));
	}
	# case "CODE" should never happen - already been run by fetch()
	case "HASH" {   # this is a directory hash
	    return easy_getattr(S_IFDIR | 0755, 1);
	}
	case "SCALAR" { # this is a scalar ref. we use these for symlinks.
	    return easy_getattr(S_IFLNK | 0777, 1);
	}
	else {          # what the hell is this file?!?
	    print "+++ What on earth is ",ref($obj)," $path ?\n";
	    return easy_getattr(S_IFREG | 0000, 0);
	}
    }
}

sub fs_getdir {
    my $obj = fetch(shift);
    return -$$obj if ref($obj) eq "ERROR"; # THINK this is a good idea.
    return -ENOENT() unless ref($obj) eq "HASH";
    return (".", "..", sort(keys %$obj), 0);
}

sub fs_open {
    # doesn't really need to open, just needs to check.
    my $obj = fetch(shift);
    my $flags = shift;
    dump_open_flags($flags) if $debug;
    
    # if it's undefined, and we're not writing to it, return an error
    return -EBADF() unless defined($obj) or ($flags & O_ACCMODE());
    
    switch (ref($obj)) {
	case "ERROR"  { return -$$obj; }
	case ""       { return 0 }          # this is a real string "file"
	case "HASH"   { return -EISDIR(); } # this is a directory hash
	else          { return -ENOSYS(); } # what the hell is this file?!?
    }
}

sub fs_read {
    my $obj = fetch(shift);
    my $size = shift;
    my $off = shift;
    
    return -ENOENT() unless defined($obj);
    return -$$obj if ref($obj) eq "ERROR";
    # any other types of refs are probably bad
    return -ENOENT() if ref($obj);
    
    if ($off >  length($obj)) {
	return -EINVAL();
    } elsif ($off == length($obj)) {
	return 0; # EOF
    }
    return substr($obj, $off, $size);
}

sub fs_readlink {
    my $obj = fetch(shift);
    return -$$obj if ref($obj) eq "ERROR";
    return -EINVAL() unless ref($obj) eq "SCALAR";
    return $$obj;
}

sub fs_release {
    my ($path, $flags) = @_;
    dump_open_flags($flags) if $debug;
    return 0;
}

sub fs_statfs {
    return (
        255, # $namelen,
        1,1, # $files, $files_free,
        1,1, # $blocks, $blocks_avail, # 0,0 seems to hide it from df?
        2,   # $blocksize,
    );
}

sub fs_truncate {
    my $obj = fetch(shift, ""); # run anything to set it to ""
    return -$$obj if ref($obj) eq "ERROR";
    return 0;
}

sub fs_write {
    my ($path, $buf, $off) = @_;
    my $obj = fetch($path, $buf, $off); # this runs the coderefs!
    return -$$obj if ref($obj) eq "ERROR";
    return length($buf);
}

1; # for use() or require()

__END__